/* -- translated by f2c (version 20031025).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include "f2c.h"
/* Common Block Declarations */
struct {
char versionc[5];
} comver_;
#define comver_1 comver_
struct {
integer miditime, lasttime;
} comevent_;
#define comevent_1 comevent_
struct {
integer levson[25], levsoff[25], imidso[25], naccbl[25], laccbl[250]
/* was [25][10] */, jaccbl[250] /* was [25][10] */, nusebl;
logical slmon[25], dbltie;
} comslm_;
#define comslm_1 comslm_
struct {
integer imidi[25];
real trest[25];
integer mcpitch[20], mgap, iacclo[150] /* was [25][6] */, iacchi[150]
/* was [25][6] */, midinst[24], nmidcrd, midchan[48] /*
was [24][2] */, numchan, naccim[25], laccim[250] /* was [25][
10] */, jaccim[250] /* was [25][10] */;
logical crdacc, notmain, restpend[25], relacc, twoline[24], ismidi;
shortint mmidi[614400] /* was [25][24576] */;
logical debugmidi;
} commidi_;
#define commidi_1 commidi_
struct {
integer midivel[24], midvelc[25], midibal[24], midbc[25], miditran[24],
midtc[25], noinst;
shortint iinsiv[24];
} commvel_;
#define commvel_1 commvel_
struct {
integer ipbuf, ilbuf, nlbuf;
shortint lbuf[4000];
char bufq[65536];
} inbuff_;
#define inbuff_1 inbuff_
struct {
integer musize;
real whead20;
} commus_;
#define commus_1 commus_
union {
struct {
integer iv, ivxo[600], ipo[600];
real to[600], tno[600];
integer nnl[24], nv, ibar, mtrnuml, nodur[4800] /* was [24][200] */,
lenbar, iccount, idum, itsofar[24], nib[360] /* was [24][
15] */, nn[24];
logical rest[4800] /* was [24][200] */;
integer lenbr0, lenbr1;
logical firstline, newmeter;
} _1;
struct {
integer iv, ivxo[600], ipo[600];
real to[600], tno[600];
integer nnl[24], nv, ibar, mtrnuml, nodur[4800] /* was [24][200] */,
lenbar, iccount, nbars, itsofar[24], nib[360] /* was [24][
15] */, nn[24];
logical rest[4800] /* was [24][200] */;
integer lenbr0, lenbr1;
logical firstline, newmeter;
} _2;
} a1ll_;
#define a1ll_1 (a1ll_._1)
#define a1ll_2 (a1ll_._2)
struct {
integer n69[25], n34[25];
} comdiag_;
#define comdiag_1 comdiag_
struct {
integer mmacstrt[500] /* was [25][20] */, mmacend[500] /*
was [25][20] */, immac, mmactime[20], nmidsec, msecstrt[1500]
/* was [25][60] */, msecend[1500] /* was [25][60] */;
logical mmacrec, gottempo;
} commmac_;
#define commmac_1 commmac_
struct {
integer linewcom[20000];
} truelinecount_;
#define truelinecount_1 truelinecount_
struct {
logical lastchar, fbon, issegno;
integer ihead;
logical isheadr;
integer nline;
logical isvolt;
real fracindent;
integer nsperi[24], linesinpmxmod, line1pmxmod, lenbuf0;
} c1omget_;
#define c1omget_1 c1omget_
struct {
integer naskb;
real task[40], wask[40], elask[40];
} comas1_;
#define comas1_1 comas1_
struct {
real udsp[50], tudsp[50];
integer nudsp;
real udoff[480] /* was [24][20] */;
integer nudoff[24];
} comudsp_;
#define comudsp_1 comudsp_
struct comtol_1_ {
real tol;
};
#define comtol_1 (*(struct comtol_1_ *) &comtol_)
struct {
shortint ipslon[25], lusebl[10], jusebl[10];
} comips_;
#define comips_1 comips_
struct {
logical islast, usevshrink;
} comlast_;
#define comlast_1 comlast_
union {
struct {
real space[80];
integer nb;
real prevtn[24], flgndv[24], flgndb, eskgnd, ptsgnd;
integer ivmxsav[48] /* was [24][2] */, nvmxsav[24];
} _1;
struct {
real space[80];
integer nb;
real prevtn[24], flgndv[24];
logical flgndb;
real eskgnd, ptsgnd;
integer ivmxsav[48] /* was [24][2] */, nvmxsav[24];
} _2;
} comnsp_;
#define comnsp_1 (comnsp_._1)
#define comnsp_2 (comnsp_._2)
union {
struct {
integer mult[4800] /* was [24][200] */, iv, nnl[24], nv, ibar,
ivxo[600], ipo[600];
real to[600], tno[600], tnote[600], eskz[4800] /* was [24][200] */;
integer ipl[4800] /* was [24][200] */, ibm1[216] /* was [24][9]
*/, ibm2[216] /* was [24][9] */, nolev[4800] /* was [24][
200] */, ibmcnt[24], nodur[4800] /* was [24][200] */,
jn, lenbar, iccount, nbars, itsofar[24], nacc[4800] /*
was [24][200] */, nib[360] /* was [24][15] */, nn[24],
lenb0, lenb1;
real slfac;
integer musicsize;
real stemmax, stemmin, stemlen;
integer mtrnuml, mtrdenl, mtrnmp, mtrdnp, islur[4800] /* was [24][
200] */, ifigdr[250] /* was [2][125] */, iline;
logical figbass, figchk[2], firstgulp;
integer irest[4800] /* was [24][200] */, iornq[4824] /*
was [24][201] */, isdat1[202], isdat2[202], nsdat, isdat3[202]
, isdat4[202];
logical beamon[24], isfig[400] /* was [2][200] */;
char sepsymq[24], sq[1], ulq[216] /* was [24][9] */;
} _1;
struct {
integer mult[4800] /* was [24][200] */, jv, nnl[24], nv, ibar,
ivxo[600], ipo[600];
real to[600], tno[600], tnote[600], eskz[4800] /* was [24][200] */;
integer ipl[4800] /* was [24][200] */, ibm1[216] /* was [24][9]
*/, ibm2[216] /* was [24][9] */, nolev[4800] /* was [24][
200] */, ibmcnt[24], nodur[4800] /* was [24][200] */,
jn, lenbar, iccount, nbars, itsofar[24], nacc[4800] /*
was [24][200] */, nib[360] /* was [24][15] */, nn[24],
lenb0, lenb1;
real slfac;
integer musicsize;
real stemmax, stemmin, stemlen;
integer mtrnuml, mtrdenl, mtrnmp, mtrdnp, islur[4800] /* was [24][
200] */, ifigdr[250] /* was [2][125] */, iline;
logical figbass, figchk[2], firstgulp;
integer irest[4800] /* was [24][200] */, iornq[4824] /*
was [24][201] */, isdat1[202], isdat2[202], nsdat, isdat3[202]
, isdat4[202];
logical beamon[24], isfig[400] /* was [2][200] */;
char sepsymq[24], sq[1], ulq[216] /* was [24][9] */;
} _2;
} all_;
#define all_1 (all_._1)
#define all_2 (all_._2)
struct {
real eskz2[4800] /* was [24][200] */;
} comeskz2_;
#define comeskz2_1 comeskz2_
struct {
integer ntot;
} comntot_;
#define comntot_1 comntot_
struct {
real hpttot[176];
} comhsp_;
#define comhsp_1 comhsp_
struct {
logical ispoi;
} compoi_;
#define compoi_1 compoi_
struct {
logical isbbm;
} combbm_;
#define combbm_1 combbm_
struct {
real ask[2500];
integer iask;
logical topmods;
} comas3_;
#define comas3_1 comas3_
struct {
integer ivbj1, ivbj2;
logical isbjmp, isbj2;
} combjmp_;
#define combjmp_1 combjmp_
struct {
integer noctup;
} comoct_;
#define comoct_1 comoct_
union {
struct {
integer ixtup;
logical vxtup[24];
integer ntupv[216] /* was [24][9] */, nolev1[24], mtupv[216]
/* was [24][9] */, nxtinbm[24], islope[24];
real xelsk[24], eloff[216] /* was [24][9] */;
integer nssb[24], issb[24], lev1ssb[480] /* was [24][20] */;
} _1;
struct {
integer ixtup;
logical vxtup[24];
integer ntupv[216] /* was [24][9] */, nolev1[24], mtupv[216]
/* was [24][9] */, nxtinbm[24], islope[24];
real xels11[24], eloff[216] /* was [24][9] */;
integer nssb[24], issb[24], lev1ssb[480] /* was [24][20] */;
} _2;
} comxtup_;
#define comxtup_1 (comxtup_._1)
#define comxtup_2 (comxtup_._2)
struct {
logical drawbm[24];
} comdraw_;
#define comdraw_1 comdraw_
struct {
integer nvmx[24], ivmx[48] /* was [24][2] */, ivx;
} commvl_;
#define commvl_1 commvl_
struct {
integer ihnum3;
logical flipend[24];
integer ixrest[24];
} strtmid_;
#define strtmid_1 strtmid_
struct {
logical bar1syst;
real fixednew, scaldold, wheadpt, fbar, poenom;
} comask_;
#define comask_1 comask_
struct {
integer itopfacteur, ibotfacteur, interfacteur, isig0, isig, lastisig;
real fracindent, widthpt, height, hoffpt, voffpt;
integer idsig, lnam[24];
char inameq[1896];
} comtop_;
#define comtop_1 comtop_
struct {
integer ntrill, ivtrill[24], iptrill[24];
real xnsktr[24];
integer ncrd, icrdat[193], icrdot[193], icrdorn[193], nudorn, kudorn[63];
real ornhshft[63];
integer minlev, maxlev, icrd1, icrd2;
} comtrill_;
#define comtrill_1 comtrill_
struct {
integer nnb;
real sumx, sumy;
integer ipb[24];
real smed;
} comipb_;
#define comipb_1 comipb_
union {
struct {
logical novshrinktop, cstuplet;
} _1;
struct {
logical novshrinktop;
real cstuplte;
} _2;
} comnvst_;
#define comnvst_1 (comnvst_._1)
#define comnvst_2 (comnvst_._2)
union {
struct {
integer itfig[148] /* was [2][74] */;
char figq[1480] /* was [2][74] */;
integer ivupfig[148] /* was [2][74] */, nfigs[2];
real fullsize[24];
integer ivxfig2;
} _1;
struct {
integer itfig[148] /* was [2][74] */;
char figqq[1480] /* was [2][74] */;
integer ivupfig[148] /* was [2][74] */, nfigs[2];
real fullsize[24];
integer ivxfig2;
} _2;
} comfig_;
#define comfig_1 (comfig_._1)
#define comfig_2 (comfig_._2)
struct comtrans_1_ {
char cheadq[60];
};
#define comtrans_1 (*(struct comtrans_1_ *) &comtrans_)
struct compage_1_ {
real widthpt, ptheight, hoffpt, voffpt;
integer nsyst, nflb, ibarflb[41], isysflb[41], npages, nfpb, ipagfpb[19],
isysfpb[19];
logical usefig;
real fintstf, gintstf, fracsys[30];
integer nmovbrk, isysmb[31], nistaff[41];
};
#define compage_1 (*(struct compage_1_ *) &compage_)
struct cblock_1_ {
real etatop, etabot, etait, etatc, etacs1, hgtin, hgtti, hgtco, xilbn,
xilbtc, xilhdr, xilfig, a, b;
integer inhnoh;
};
#define cblock_1 (*(struct cblock_1_ *) &cblock_)
struct cominbot_1_ {
integer inbothd;
};
#define cominbot_1 (*(struct cominbot_1_ *) &cominbot_)
struct comstart_1_ {
real facmtr;
};
#define comstart_1 (*(struct comstart_1_ *) &comstart_)
struct comtitl_1_ {
char instrq[120], titleq[120], compoq[120];
logical headlog;
integer inskip, ncskip, inhead;
};
#define comtitl_1 (*(struct comtitl_1_ *) &comtitl_)
struct spfacs_1_ {
real grafac, acgfac, accfac, xspfac, xb4fac, clefac, emgfac, flagfac,
dotfac, bacfac, agc1fac, gslfac, arpfac, rptfac;
integer lrrptfac;
real dbarfac, ddbarfac, dotsfac, upstmfac, rtshfac;
};
#define spfacs_1 (*(struct spfacs_1_ *) &spfacs_)
struct combmh_1_ {
real bmhgt, clefend;
};
#define combmh_1 (*(struct combmh_1_ *) &combmh_)
struct comdyn_1_ {
integer ndyn, idyndat[99], levdsav[24], ivowg[12];
real hoh1[12], hoh2[12], hoh2h1[2];
integer ntxtdyn, ivxiptxt[41];
char txtdynq[5248];
integer idynda2[99], levhssav[24], listcresc, listdecresc;
};
#define comdyn_1 (*(struct comdyn_1_ *) &comdyn_)
struct comkbdrests_1_ {
integer levbotr[8], levtopr[8];
logical kbdrests;
};
#define comkbdrests_1 (*(struct comkbdrests_1_ *) &comkbdrests_)
struct cominsttrans_1_ {
integer iinsttrans[24], itranskey[24], itransamt[24], instno[24],
ninsttrans;
logical earlytranson, laterinsttrans;
};
#define cominsttrans_1 (*(struct cominsttrans_1_ *) &cominsttrans_)
struct comsize_1_ {
integer isize[24];
};
#define comsize_1 (*(struct comsize_1_ *) &comsize_)
struct {
integer nnodur;
real wminnh[3999];
integer nnpd[4000];
real durb[4000];
integer iddot, nptr[3999], ibarcnt, mbrest, ibarmbr, ibaroff;
real udsp[3999], wheadpt;
logical gotclef;
real sqzb[4000];
} c1omnotes_;
#define c1omnotes_1 c1omnotes_
struct {
integer narp;
real tar[8];
integer ivar1[8], ipar1[8], levar1[8], ncmar1[8];
real xinsnow;
logical lowdot;
} comarp_;
#define comarp_1 comarp_
struct {
integer midisig;
} commidisig_;
#define commidisig_1 commidisig_
struct {
integer listslur;
logical upslur[48] /* was [24][2] */;
integer ndxslur;
logical fontslur, wrotepsslurdefaults;
real slurcurve;
} comslur_;
#define comslur_1 comslur_
struct {
integer ivg[37], ipg[37], nolevg[74], itoff[148] /* was [2][74] */;
real aftshft;
integer nng[37], ngstrt[37], ibarmbr, mbrest;
real xb4mbr;
integer noffseg, ngrace, nvolt, ivlit[83], iplit[83], nlit;
real graspace[37];
integer lenlit[83], multg[37];
logical upg[37], slurg[37], slashg[37];
integer naccg[74];
char voltxtq[120], litq[10624];
} comgrace_;
#define comgrace_1 comgrace_
struct {
integer is1n1, is2n1, irzbnd, isnx;
} comsln_;
#define comsln_1 comsln_
struct {
real eonk, ewmxk;
} comeon_;
#define comeon_1 comeon_
struct {
integer ipl2[4800] /* was [24][200] */;
} comipl2_;
#define comipl2_1 comipl2_
struct {
integer ibmtyp;
} combeam_;
#define combeam_1 combeam_
struct {
integer macnum;
logical mrecord, mplay;
integer macuse, icchold;
char lnholdq[128];
logical endmac;
} commac_;
#define commac_1 commac_
struct {
integer nvmx[24], ivmx[48] /* was [24][2] */, ivx;
real fbar;
integer nacc[4800] /* was [24][200] */;
} c1ommvl_;
#define c1ommvl_1 c1ommvl_
union {
struct {
integer nkeys, ibrkch[18], newkey[18];
logical iskchb;
integer idsig, isig1, mbrestsav;
logical kchmid[18], ornrpt, shifton, barend;
integer noinst;
logical stickys;
} _1;
struct {
integer nkeys, ibrkch[18], newkey[18];
logical iskchb;
integer idumm1, isig1, mbrestsav;
logical kchmid[18], logdumm1, logdumm2, barend;
integer noinst;
logical logdumm3;
} _2;
} comkeys_;
#define comkeys_1 (comkeys_._1)
#define comkeys_2 (comkeys_._2)
struct {
logical isligfont;
} comligfont_;
#define comligfont_1 comligfont_
struct {
logical lastchar, rptnd1, sluron[48] /* was [24][2] */, fbon,
ornrpt, stickys;
integer movbrk, movnmp, movdnp, movgap;
real parmov, fintstf, gintstf;
logical rptprev, equalize;
char rptfq1[1], rptfq2[1];
} comget_;
#define comget_1 comget_
struct {
logical ignorenats;
} comignorenats_;
#define comignorenats_1 comignorenats_
struct {
integer nnodur, lastlev, ndlev[48] /* was [24][2] */;
logical shifton, setis, notcrd;
integer npreslur;
logical was2[24];
integer ninow;
logical nobar1;
integer nsystp[40], ipage;
logical optlinebreakties, headerspecial;
} comnotes_;
#define comnotes_1 comnotes_
struct {
integer ihdht;
logical lower;
char headrq[80], lowerq[80];
integer ihdvrt;
} comhead_;
#define comhead_1 comhead_
struct {
integer nfb[24];
real t1fb[960] /* was [24][40] */, t2fb[960] /* was [24][40] */;
char ulfbq[960] /* was [24][40] */;
integer ifb;
real tautofb;
logical autofbon;
real t1autofb;
} comfb_;
#define comfb_1 comfb_
struct {
integer ncc[24];
real tcc[240] /* was [24][10] */;
integer ncmidcc[240] /* was [24][10] */, ndotmv[24];
real updot[480] /* was [24][20] */, rtdot[480] /* was [24][20] */;
} comcc_;
#define comcc_1 comcc_
struct {
logical bcspec;
} combc_;
#define combc_1 combc_
struct {
integer nsperi[24], nspern[24];
logical rename;
integer iiorig[24];
} comnvi_;
#define comnvi_1 comnvi_
struct {
integer ip1mac[20], il1mac[20], ip2mac[20], il2mac[20], ic1mac[20], ilmac,
iplmac;
} c1ommac_;
#define c1ommac_1 c1ommac_
struct {
char clefq[24];
} comclefq_;
#define comclefq_1 comclefq_
struct {
integer numarpshift, ivarpshift[20], iparpshift[20];
real arpshift[20];
} comarpshift_;
#define comarpshift_1 comarpshift_
struct {
integer ibarcnt;
} combibarcnt_;
#define combibarcnt_1 combibarcnt_
struct {
integer ivxudorn[63];
} comivxudorn_;
#define comivxudorn_1 comivxudorn_
struct {
integer nbc, ibcdata[36];
} comcb_;
#define comcb_1 comcb_
struct {
integer nasksys;
real wasksys[800], elasksys[800];
} comas2_;
#define comas2_1 comas2_
struct {
logical cwrferm[24];
} comcwrf_;
#define comcwrf_1 comcwrf_
struct {
real elskb, tnminb[3999];
} linecom_;
#define linecom_1 linecom_
/* Initialized data */
struct {
char e_1[60];
} comtrans_ = { " "
" " };
struct {
real e_1[4];
integer fill_2[127];
real e_3[30];
integer fill_4[73];
} compage_ = { 524.f, 740.f, 0.f, 0.f, {0}, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f,
0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f,
0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f, 0.f };
struct {
real e_1[14];
integer e_2;
} cblock_ = { .5f, .25f, .4f, .4f, .2f, 12.f, 21.f, 12.f, 4.f, 1.6f, 5.f,
5.7f, 1.071f, 2.714f, 16 };
struct {
integer e_1;
} cominbot_ = { 16 };
struct {
real e_1;
} comstart_ = { .55f };
struct {
char e_1[360];
logical e_2;
integer fill_3[3];
} comtitl_ = { " "
" "
" "
" "
" "
" ", FALSE_ };
struct {
real e_1[14];
integer e_2;
real e_3[5];
} spfacs_ = { 1.3333f, .4f, .7f, .3f, .2f, 2.f, 1.f, .7f, .7f, .9f, .5f,
9.f, 1.7f, 1.32f, 2, .47f, .83f, .17f, .5f, 1.f };
struct {
real e_1[2];
} combmh_ = { 1.1f, 2.3f };
struct {
integer fill_1[124];
integer e_2[12];
real e_3[26];
integer fill_4[1479];
} comdyn_ = { {0}, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 2.2f, 1.7f, 1.2f,
.7f, 1.3f, 1.3f, .4f, .8f, 1.2f, .8f, 1.2f, 1.6f, -2.7f, -2.2f,
-1.7f, -1.2f, -2.3f, -2.1f, -1.f, -1.7f, -2.1f, -1.6f, -1.9f,
-2.3f, -.3f, .3f };
struct {
integer e_1[16];
logical e_2;
} comkbdrests_ = { 0, 0, 0, 2, 1, 4, 5, 4, 9, 7, 5, 5, 7, 5, 6, 6, FALSE_
};
struct {
integer e_1[24];
integer fill_2[73];
logical e_3[2];
} cominsttrans_ = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, {0}, FALSE_, FALSE_ };
struct {
integer e_1[24];
} comsize_ = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0 };
struct {
real e_1;
} comtol_ = { .001f };
/* Table of constant values */
static integer c__9 = 9;
static integer c__1 = 1;
static integer c__44 = 44;
static integer c__2 = 2;
static integer c__4 = 4;
static integer c__128 = 128;
static integer c__3 = 3;
static logical c_true = TRUE_;
static logical c_false = FALSE_;
static integer c__92 = 92;
static integer c__11 = 11;
static integer c__12 = 12;
static integer c__17 = 17;
static integer c__14 = 14;
static integer c__129 = 129;
static integer c__5 = 5;
static integer c__22 = 22;
static integer c__0 = 0;
static integer c__6 = 6;
static integer c__27 = 27;
static integer c__7 = 7;
static integer c__10 = 10;
static integer c__20 = 20;
static real c_b761 = -2.f;
static real c_b762 = 0.f;
static real c_b807 = 1.f;
static integer c__8 = 8;
static integer c__16 = 16;
static integer c__23 = 23;
static integer c__39 = 39;
static integer c__96 = 96;
static integer c__21 = 21;
static integer c__19 = 19;
static integer c__24 = 24;
static integer c__13 = 13;
static integer c__28 = 28;
static integer c__18 = 18;
static real c_b1659 = 2.f;
static integer c__30 = 30;
static integer c__60 = 60;
static integer c__80 = 80;
static integer c__256 = 256;
static integer c__34 = 34;
static integer c__120 = 120;
static integer c__240 = 240;
static integer c__255 = 255;
static integer c__47 = 47;
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static char date[9] = "3 Apr 13 ";
static char version[5] = "2.7 ";
static integer maxit = 200;
static integer ncalls = 0;
static logical isfirst = TRUE_;
/* System generated locals */
address a__1[2], a__2[4], a__3[3];
integer i__1, i__2, i__3[2], i__4[4], i__5[3], i__6;
real r__1;
char ch__1[48], ch__2[64], ch__3[37], ch__4[55], ch__5[56];
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char
*, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer f_inqu(inlist *), f_open(olist *), f_clos(cllist *);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
static real devnorm0;
static logical optimize;
extern /* Subroutine */ int poestats_(integer *, real *, real *, real *),
writemidi_(char *, integer *, ftnlen);
static integer ncomments, ip1, ilb, icm;
static real poe[125];
static integer ivt, ivx;
static real poe0[125];
static integer ljob, ipoe[125];
extern /* Subroutine */ int pmxa_(char *, integer *, logical *, integer *,
integer *, logical *, ftnlen), pmxb_(logical *, real *, integer *
, logical *);
static integer ivtt, isys, ljob4;
extern /* Subroutine */ int stop1_(void);
extern integer iargc_(void);
static integer nbari[125], nbars[125], iinst, isysd, numit, isyst, isysu,
nsyst, nbars0[125];
static real poebar;
extern /* Subroutine */ int getarg_(integer *, char *, ftnlen);
static integer idnord, iplast;
static logical fexist;
static real devpmx;
static integer iupord;
extern integer lenstr_(char *, integer *, ftnlen);
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer ndxpmx;
static real poebar0;
static char jobname[44], infileq[47], lnholdq[128];
static real devnorm;
static integer numargs, nstaves;
extern /* Subroutine */ int sortpoe_(integer *, real *, integer *);
/* Fortran I/O blocks */
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 5, 0, "(a)", 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 18, 1, "(a)", 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___34 = { 0, 6, 0, 0, 0 };
static cilist io___35 = { 0, 15, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___40 = { 0, 15, 0, 0, 0 };
static cilist io___42 = { 0, 15, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 15, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, 0, 0 };
static cilist io___61 = { 0, 15, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, "(5x,20i3)", 0 };
static cilist io___63 = { 0, 15, 0, "(5x,20i3)", 0 };
static cilist io___64 = { 0, 6, 0, 0, 0 };
static cilist io___65 = { 0, 15, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 15, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___69 = { 0, 15, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, "(5x,20i3)", 0 };
static cilist io___71 = { 0, 15, 0, "(5x,20i3)", 0 };
static cilist io___72 = { 0, 6, 0, "(5x,20i3)", 0 };
static cilist io___73 = { 0, 15, 0, "(5x,20i3)", 0 };
/* This program, PMX, developed by Don Simons */
/* (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with */
/* MusiXTeX and TeX, its purpose is to allow the user to create high-quality */
/* typeset musical scores by including a sequence of PMX commands in an ASCII */
/* input file. */
/* This program is free software: you can redistribute it and/or modify */
/* it under the terms of the GNU General Public License as published by */
/* the Free Software Foundation, either version 3 of the License, or */
/* (at your option) any later version. */
/* This program is distributed in the hope that it will be useful, */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
/* GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public License */
/* along with this program. If not, see . */
/* To compile with gfortran: */
/* 1. Merge all files using copy *.for epmx[nnnn].for */
/* 2. Search and replace all character*65536 with character*131072 */
/* 3. Comment/uncomment getarg lines */
/* 4. gfortran -O pmx[nnnn].for -o pmxab.exe */
/* To do */
/* Correct Rainer's email address in manual */
/* Linesplit (\\) in h */
/* Tt at start of a movement. */
/* Toggle midi on or off; allow midi only. */
/* Page number printed on 1st page even if 1 system. */
/* Still need inserted space for chordal accidentals */
/* Voicewise transposition. */
/* better segno */
/* coda */
/* duevolte */
/* Fix xtup bracket direction in 2-line staves?? (maybe leave as is) */
/* Sticky ornaments with shifts. */
/* Deal with Werner's vertical spacing thing associated with title. */
/* Multiple ties in midi */
/* Werner's missing c in MIDI due to start/stop ties on same note. */
/* Beams with single 64ths */
/* 128ths and/or dotted 64ths */
/* Close out MIDI with integral # of beats? */
/* Increase ast dimensions or redo logic. */
/* Does slur direction get set for user-defined single-note stem dir'ns? */
/* Transpose by sections. */
/* Optimization loop over sections only */
/* Command-line option to read nbarss in. Write out nbarss when optimizing. */
/* (or just read from .plg?) */
/* Beams over bar lines. */
/* 2-digit figures */
/* A real coule (slanted line between notes in a chord) */
/* Dotted slurs for grace notes. */
/* Undotted chord notes with dotted main note. */
/* Forced line break without line number */
/* Fix dot moving when 2nds in chord get flipped */
/* To do: increase length on notexq in dodyn */
/* 2.70 */
/* To do: coda */
/* To do: fix grace note spacing problem (partially done) */
/* 2.622 */
/* Redefine midtc(..) and miditran(..); clean up all transpositions/key changes */
/* Kn[+/-...] \ignorenats at signature changes */
/* Fix tie checks in doslur() and dopsslur() to subtract iTransAmt from nolevs */
/* before checking and setting pitch levels levson() and levsoff() */
/* Define midisig separately from isig. Put in common commidisig. */
/* Use for explicit midi signature and for accid corrections to midi piches */
/* in addmidi. */
/* 2.621 */
/* Make keyboard rest option work in xtuplets. Created subroutine */
/* chkkbdrests, modified make2bar to include calls to chkkbdrests as rqd. */
/* 2.620 */
/* Allow user-defined rest height tweaks at start of beam. */
/* 2.619 */
/* At movement break, change \nbinstruments in \newmovement macro; add */
/* 3rd arg to \newmovement in pmx.tex; modify pmxb.for and getnote.for */
/* to remove call to newnoi and change call to \newmovement */
/* 2.618 */
/* Add option Ac[l,4] to set vert and horiz size and offsets to properly */
/* center page for letter or a4 paper. */
/* 2.617 */
/* In g1etnote, change if-check for note to use index(...) instead */
/* of ichar(charq) since it was messing up gfortran optimizer */
/* After pmxa, search for and remove penultimate line / */
/* because it was screwing up linux-compiled versions */
/* Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) */
/* 2.616 (111110) */
/* Allow hairpins to span multiple notes groups (gulps). */
/* 2.615+ (110810) */
/* Fix midi when some instruments are transposed, by subtracting */
/* iTransAmt(instno(iv)) from pitch values sent to via addmidi in */
/* make2bar.for (for main notes) and docrd (for chord notes) */
/* 2.615 (110725) */
/* Fig bug with size-setting (in topfile) when instrument has >1 staves */
/* 2.615 (110724) */
/* Make AS[0|-|s|t]... really set sizes */
/* 2.614 */
/* Mod notex.for to fix Terry's bug with raised dotted rests (caused */
/* by double-hboxing). */
/* 2.613 */
/* Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. */
/* 2.612 */
/* Enhance AS to allow s or t for smallsize or tinysize */
/* 2.611 */
/* Error trap for "D" before any notes in a block. */
/* 2.610 */
/* Instrument-wise key changes and transposition (incomplete) */
/* 2.603 */
/* 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors */
/* following reading in an include file. */
/* 101121 Added some error messages in g1etset.for setup data */
/* 2.602 */
/* Correct slur indexing in linebreakslurs. */
/* Account for comment lines in line count for error messages */
/* 2.601 */
/* Bug fix: allow 24 slurs with graces */
/* 2.60 Changes made make it really big */
/* increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o */
/* major reprogramming, and 16 may also be a problem (icmm) */
/* nm=24 (voices) done */
/* 24 slurs done */
/* 24 simultaneous beams (Replace index 24 by 0, so get 0-23) */
/* bufq*131072 (gfortran only) */
/* getarg syntax (gfortran only) */
/* 2.523+ */
/* Fix voice numbering for normal dynamics and text dynamics */
/* 2.523 */
/* Version of bigpmx first posted to Hiroaki's web site. */
/* 2.522 */
/* 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. */
/* With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. */
/* 5/13/10 Fix log2 function */
/* 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. */
/* 2.521+ */
/* 091025 Enable dotting 2nd part of linebreak slur or tie. */
/* To adjust barno height due to linebreak slur, use \bnrs instead of */
/* explicitly redefining \raisebarno (pmxb) */
/* 2.521 */
/* Bugfix */
/* 2.520 */
/* 090519 Enable ligfonts (special figured bass characters) */
/* 2.519 */
/* Fix another bug which kept \sk from being output so misaligned some notes. */
/* 2.518 */
/* Fix bugs: referencing fig data, char declaration for member of */
/* common/comfig/ */
/* 2.517 */
/* Allow figures in voice 1 + any one other. */
/* 2.516 */
/* Allow figures in voice #2 */
/* 2.515+ to do: Change manual and activate rule against clef change in voice #2. */
/* 2.515 */
/* 071222 Changes in getnote to allow auto forced beams to start anywhere. */
/* 071206 In make2bar, shift fermataup7 to left over centered pause. */
/* 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line */
/* staff (it was screwing up vertical justification). */
/* n34 for tweaks to midi durations of quarter note septuplets. */
/* To do: In ref250.tex, the tables where 's,t,)' is explained, the line */
/* [+,- i] ... Vertical adjustment of the start of second segment */
/* should it be replaced by */
/* [s +,- i] ... Vertical adjustment of the start of second segment */
/* 2.514 */
/* Changes in make2bar to get horizontal spacing right when normal grace */
/* follows after grace */
/* Changes in dograce to get octaves right for any material entered inside */
/* \gaft, which shields transpose register changes from the outside world. */
/* 2.513 */
/* In make1bar, near end, for forced beams starting with a rest, copy hgt and */
/* slope tweaks to ALL notes after first, not just the second one, so if */
/* there's more than one rest at start the tweaks are still observed. */
/* In beamid and beamend, add stand-alone triply-flagged notes for xtups. */
/* 2.512 */
/* Near end of pmxb, fix error trap to allow redundant 'RD' */
/* Enable multiplicity down-up '][' within xtup. */
/* 2.511 */
/* Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by */
/* adjusteskz as in bar 7 of barsant. */
/* 2.510a */
/* Test: remove restriction on tempo changes in MIDI macros */
/* Send to CM for beta testing. */
/* 2.509+ */
/* To do: Correct manual on AS. "-" is for smaller staves. */
/* 2.510 */
/* Forgot to declare litq, voltxtq as character in subroutine getgrace */
/* 2.509 */
/* Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) */
/* 2.508 */
/* Allow graces in xtups. New subroutine getgrace. */
/* 2.507 */
/* To do: Raise/lower figures. */
/* To do: Add 24, 29 to list of musicsizes in manual */
/* New sub adjusteskz to account for ask's when computing lengths of */
/* brackets for unbeamed xtups, slopes and horizontal posn's of number */
/* Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags */
/* Add look-left option for keyboard rests, "L" in rest command, set iornq(30) */
/* 2.506 */
/* Fix bug with AK, when simultaneous rests have same duration, use defaults. */
/* 2.505 */
/* Keyboard rests AK */
/* 2.504 */
/* Space after normal grace: option X[n] */
/* Fixed og when nv .ne. noinst, by using sepsymq instead of '&' */
/* (To do) length of xtup bracket when there is added non-collision space. */
/* Trap musicsize if .ne. 16,20,24,29. */
/* 2.503 */
/* Enable arpeggio left shift with ?-x */
/* To do: In manual, arpeggio over 2 staves. */
/* Allow musicsize of 24 and 29. Had to define meter font size explicitly, */
/* also change font size for text dynamics, but not much else so far. */
/* Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn */
/* was called, causing error in printing replacement number. */
/* 2.502 */
/* Incorporate Dirk Laurie's patch to use { , } , for ties. */
/* Figure height adjustment: append +[n] */
/* Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) */
/* 2.501 */
/* Readjust horizontal offset back to .8 in LineBreakTies */
/* Fix zero-subscript (iudorn) in putorn */
/* 2.50 */
/* Increase number of text-dynamics (dimension of txtdynq) per block */
/* from 12 to 41. */
/* Slur option n to override altered default curvature. */
/* Allow default ps slur curvature tweaks with Ap+/-c */
/* 2.416 */
/* Increase length of textdynq from 24 to 128 */
/* (Todo) Add comment in manual about blank lines at end. */
/* Configuration file: Define subroutine getpmxmod, check path in environment */
/* variable pmxmoddir, check existence, read lines into bufq after setup. */
/* Increase dimension on idynn in dodyn from 4 to 10 for max number */
/* of marks in a bar */
/* Increase allowable # of lines from 2000 to 4000. */
/* (To do) Replace definition of \liftpausc per Olivier. */
/* (To do) Fix extraneous error message if RD is placed at very end. */
/* 2.415 */
/* Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt */
/* instead of redefining \xnum. Change font used to \smallfont (as for */
/* normal xtups, */
/* Allow slur to start on rest. */
/* 2.414 */
/* Correct bug in crdacc when adding accidental to boundary causes number of */
/* segments to decrease */
/* Special rule for 3-accidental chords: If no 2nds, place them in order */
/* top, bottom, middle. */
/* 2.413 */
/* Correct bugs in chordal accidentals, related to left-shifted noteheads */
/* (a) Special problems with downstem when main note needs shifting */
/* (b) Assign 0 rank to boundary segs due to left-shifted noteheads */
/* 2.412 */
/* Change default horiz shift of start of seg 2 of linebreak slurs: */
/* -.7 for slurs, -1.2 for ties, */
/* Use height of start of seg 1 slur itself for end of 1 and start of 2. */
/* 2.411 */
/* "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. */
/* "s" option in start of slur/tie as precursor to vert/horiz tweaks for end */
/* of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. */
/* With "Apl", curvature adjustments on starting slur command apply to seg 1, */
/* those on ending command to seg 2. */
/* 2.410 */
/* "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine */
/* \xnum, \unbkt, \ovbkt. */
/* "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is */
/* flag, mult(5-9) is tweak value+16 */
/* 2.409 */
/* Bugfix in docrd for MIDI: Use original pitch in case main/chord were */
/* switched due to 2nds. */
/* Remove "o" from error message for "A" command. */
/* New syntax: optional instrument number separator ":" in movement */
/* break command to precede a 2-digit instrument. */
/* Conditional output formats for \setname at movement break to allow */
/* instrument numbers >9. */
/* Bugfix in coding to raise barno due to slur over line break (pmxb) */
/* Move date/version data statement in pmxab to a better place. */
/* 2.408 */
/* Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). */
/* Bug fix in \liftPAusep in notex.for and in pmx.tex */
/* Character variables for version and date */
/* For up-stem single graces slurred to down-stem, shift slur start left by */
/* 0.8 so slur doesn't get too short. */
/* Initialize and slide mult, same as other full-program variables in /all/. */
/* 2.407 */
/* Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, */
/* 2.406 */
/* Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing */
/* equalization). */
/* Put dimensions of double sharps and flats in crdacc (for chords). */
/* Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' */
/* Use only first 4 bits of mult for multiplicity+8, so rest can be used */
/* for other stuff. */
/* Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. */
/* 2.405: Not published but saved for safety. */
/* Option Aph to write \special{header=psslurs.pro} top of each page, so */
/* dviselec will work OK. */
/* 2.404 */
/* Allow slur to end on rest, but not start on a rest. Efaults height */
/* of ending is default height of start (before any automatic or user- */
/* defined djustments). User may adjust height as normal from default. */
/* 2.403 */
/* Bugfix: turn off repeated beaming patterns.at end of non-last voice. */
/* 2.402 */
/* Automatic repeated forced beams. Start with "[:" End with next explicit */
/* forced beam or end of input block. */
/* Increase # of forced beams per line of music per input block from 20 to 40 */
/* 2.401 */
/* Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. */
/* Makes 1st part normal shape, and starts 2nd part a little further left. */
/* Enable arpeggios in xtuplets. Had to make time itar(narp) a real. */
/* 2.40 */
/* Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. */
/* Fix non-ps-slur input to \midslur (third signed integer). Do not reverse */
/* sign for down-slurs. */
/* 2.359 */
/* Add error exit subroutine stop1 to make exit status g77-compatible.. */
/* Absolute octave on xtup chord note was 2 octave too high, fixed in getnote */
/* Fermata on vertically shifted rest: special trap in putorn() to set height. */
/* Correct multiple grace note spacing for small staves (in dograce, */
/* define wheadpt1 depending on staff size) */
/* 2.358 */
/* Allow curvature corrections at start of postscript slur, in dopsslur() */
/* Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust */
/* Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] */
/* Make t[ID] act like s[ID]t, most mods in spsslur(). */
/* Add spsslur() to read in data for ps slurs, call from getnote. */
/* In beamstrt, save args for SetupB in common comipb to save them for */
/* 2nd call when xtup starts with rest */
/* Add spacing for ornament ")" as if it were accidental, in make2bar(). */
/* Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() */
/* Horiz. shift start of ps grace slur, 2 places in dograce(). */
/* Horiz shift end of grace slur in endslur() */
/* Make st slurs into postscript ties. Separate subroutine dopsslur(), */
/* Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) */
/* Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. */
/* 2.357a */
/* Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote */
/* 2.357 */
/* Increase dimension for # of lit TeX strings from 52 to 83. */
/* Allow blank rest in middle of xtuplet. Only mods in g*etnote(). */
/* 2.356 */
/* Increased some dimensions from 30 to 40 to allow up to 40 pages. */
/* In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). */
/* Fix parsing of "f,h,H,HH" in sslur. */
/* Fix bug with cdot, note-level for slur termination (in getnote) */
/* 2.355 */
/* Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], */
/* n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues */
/* Make midi recognize ps ties in doslur. */
/* Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote */
/* to get octave right. */
/* 2.354 */
/* With postscript slurs, make t-slurs real ties by inserting replacement */
/* macros \tieforisu, etc, defined in pmx.tex */
/* Check for open cresc or decresc at end of input block, using list[de]cresc */
/* Hairpin syntax conditional on postscript slurs. Backup to fill in start */
/* level, using new backfill(...). Separate height tweaks for */
/* start and finish. */
/* 2.353 */
/* K-0+n to transpose by half step (rather than just change key) */
/* Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of */
/* \mbrest's */
/* Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end */
/* of input block before movement break, and at start of block after */
/* movement break, using \newmovement rather than \setzalaligne, since */
/* former already redefines \stoppiece. In second case, set rptfg2='z'. */
/* Make clefq(nm) common between pmxb and getnote; change references in */
/* getnote at 'M' to array elements, setting all new clefs as you go. */
/* 2.352 */
/* Remove \parskip redefinition from pmx.tex; write it into TeX file when */
/* "Ae" is invoked. */
/* Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine */
/* \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', */
/* translate them thru mapping to (1,4,5,6) as \midslur params, then let */
/* \psforts translate them back to ps slur macors. */
/* 2.351 */
/* Number slurs from 0 up instead of 11 down, anticipating postscript slurs. */
/* Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. */
/* Increase length of basenameq to 44 characters everywhere. */
/* Increase dimension of mcpitch (midi-chord-pitch) to 20. */
/* Set default systems per page to 1 if nv>7 */
/* In pmxb, move place where isystpg is reset to 0, so that \eject gets */
/* written when there is just one system per page. */
/* 2.35 */
/* Cautionary accidentals with 'c' anywhere in note symbol. */
/* NEW pmx.tex with \resetsize to set size to normal or small depending on */
/* current \internote. Used with new coding in dograce() to get right */
/* new size in case user has \setsize'ed some lines to \smallvalue. For */
/* \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. */
/* Affects pmx.tex. */
/* Continuation figure with fractional length. May now mix with other figures. */
/* If another figure follow Cont-fig, separate with colon. */
/* 2.342 */
/* Bugfix in getnote to recognize relative octave shift in grace at start of */
/* input block. */
/* In make2bar, initialize islhgt=0 earlier than before (possible solution */
/* to Suse g77 compile problem that I could not reproduce).. */
/* Bugfix in beamstrt & beamn1 for r2x6 c4D d d d */
/* 2.341 */
/* Syntax check: Forced page break page number must be > than previous. */
/* Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. */
/* 2.34 */
/* New pmx.tex with redefined liftpausc */
/* Bug fix with dotted, non-beamed xtups. */
/* 2.332 */
/* Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. */
/* Allow arbitrary pos. input to W in g1etnote and getnote. */
/* 2.331 */
/* Bug-fix in dodyn(..): typo on length of arg of txtdyn */
/* 2.33 */
/* Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() */
/* 2.321 */
/* Rescale accidental shifts. Still use 7 bits but now map (0,127) */
/* onto (-1.,5.35) */
/* Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups */
/* 2.32 (Noticed after posting) */
/* Prohibit "/" as figure. */
/* 2.32 (Posted) */
/* Tidied up accidentals in chords, do spacing. */
/* Still to do: */
/* check for "(" on chord notes in spacing algo */
/* small accids */
/* double accids */
/* autoshift slurs */
/* 2.310 */
/* Extra call to precrd ahead of spacing chk, and single-note crd/acc */
/* shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. */
/* 2.309 */
/* Alternate algo for accid shifts in chords. */
/* 2.308 */
/* Auto horiz. notehead shifting added to precrd. */
/* 2.307 */
/* Auto shifting of multiple accidentals in chords. */
/* "Ao" in main chord note to keep accidentals in order. Set nacc(28). */
/* If there are any manual main or chord note shifts, then */
/* If any manual shift is preceded by "A" then */
/* 1. Auto-shifting proceeds */
/* 2. "A"-shifts add to autoshifts */
/* 3. non-"A" shifts are ignored! */
/* Else (>0 man shifts, none has "A") */
/* No auto-ordering, No autoshifts, */
/* End if */
/* End if */
/* 2.306 */
/* Initialize legacy note level to middle C in case user forgets to set */
/* octave. */
/* Shift xtup note? */
/* Shift in elemskips rather than noteheads? */
/* 2.305 */
/* Stop pmxb from multiple endvolta's at start of new page. */
/* 2.304 */
/* "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on */
/* for multiple notes in the voice, "S:" last shortened note. */
/* 2.303 */
/* vshrink stuff all OK? Description is in pmxb. */
/* 2.302 */
/* Toggle vshrink with "Av". vshrink normally kicks in when \interstaff */
/* hits 20. This still needs work. */
/* Add " /" to last line if last char is not % or /. */
/* 2.301 */
/* Check in beamn1 for single note before multiplicity down-up. */
/* allow '.PMX' as well as '.pmx' */
/* 2.299 */
/* Correct typo in pmxb involving PMXbarnotrue. */
/* Replacement printed number for xtup: Unsigned integer after 'n' after 'x' */
/* Minor upgrade parsing xtuplet options 'x...' */
/* Correct dimension of nxtinbm in make2bar. */
/* 2.298 */
/* Account for doubled xtup notes in subroutine getx (user-defined spaces), */
/* by adding ndoub as an argument.. */
/* 2.297 */
/* Created and solved compiler problem. Put drawbm(NM) in its own common. */
/* Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar */
/* when \centerbar is used. */
/* Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX */
/* use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. */
/* 2.296 */
/* Correct printed numbers for forced beams with multiple xtups. For each beam */
/* make list in setupb by voice of eloff (h-offset) and mtupv (printed #) */
/* Increase lengths of jobname and infileq by 20 characters */
/* Enable whole notes and breves as 1st or last note of xtup in beamn1 and */
/* beamend, and wholes in beamid. */
/* 2.295 */
/* Midi balance Ib[n1]:[n2]:...[nn] */
/* Single-slope beam groups [...]-[...] */
/* Trap "i" unless after accidental (main notes, xtups, chord notes) */
/* 2.294 */
/* Unequal xtups with "D" to double a note in an xtup. */
/* As above, "F" will (a) increase multiplicity by 1 for marked note and next */
/* one and (b) add a dot to the first one. */
/* Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on */
/* when "." is encountered, then correcting beam start time.(end of getnote) */
/* MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... */
/* 2.293 */
/* Check for single notes spanning bar lines. */
/* Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup */
/* must be set in make2bar since beamstrt is not called, fixing problem with */
/* dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix */
/* problem when >2 staves. */
/* Add nodur to args of dodyn, so can check if stemless and avoid height tweak */
/* Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak */
/* 2.292a */
/* Undo syntax check for Type 2 or 3 TeX string starting in column 1. */
/* Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! */
/* 2.292 */
/* Allow comments in xtuplets */
/* Enable multiple octave jumps in grace notes. */
/* Allow dynamics in xtuplets. */
/* Fix bug in getdyn searching for end of text string (correct length of lineq */
/* to 128) */
/* Fix bug in dodyn, must ignore horiz. interaction tweak for */
/* user-text (idno = 0) */
/* Syntax check for Type 2 or 3 TeX string starting in column 1 */
/* (NOTE: later undone!) */
/* Syntax check for page number > npages at forced line break. */
/* 2.291 */
/* Fix error in AS command (accid spacing for small systems), making only */
/* one spec per staff, nv total. */
/* Stop using MIDI channel 10 */
/* 2.29 */
/* Fix error in console output format for # of bytes used in MIDI file. */
/* Fix bug in dograce so no space is added between grace and main note when */
/* there is a MIDI-only accidental. */
/* Fix bug so oes?+4 works. It was too ugly to explain. */
/* ...Different ways of storing accidental specs on input and output. */
/* No longer zap \writezbarno in special situations. */
/* Fix bug in dyntxt level on rest */
/* Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. */
/* Activate with Ae. (Maybe later could input alternate values for */
/* \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 */
/* in the page, and \endeq on 1st note of next-to-last line in page. */
/* 2.28 */
/* Flip direction of forced beam "[f..." */
/* Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) */
/* Fix bug in sliding ip's for txtdyn's */
/* In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) */
/* 2.27 */
/* Comment out lines in dodyn checking number of dynamic marks found. Voice */
/* order may not be monotonic if two lines on a staff. */
/* Literal dynamic: D"[text]" */
/* 2.26 */
/* Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, */
/* increasing dimension of idynn to 4 to allow 4 symbols on same note. */
/* Increase voltxtq length from 10 to 20. */
/* AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough */
/* accounting for ast's is done by defining effective headwidth */
/* whead1 in makebar2 to be 0.8*whead. */
/* 2.25 */
/* Fix logic bug with sepsym's when # of instruments changes. */
/* Slight increases in default offsets for hairpin starts after "p" */
/* 2.24 */
/* Hairpins D< or D> as toggle. */
/* Many automatic position tweaks for letter-group dynamics and hairpins. */
/* 2.23 */
/* Continued rhythmic shortcuts: space followed by "." or "," */
/* 2.22 */
/* In call to doslur, change tno(...) to tnote(...). This was only */
/* used when checking to slurs per stem directions, and should have been */
/* the note duration all along. */
/* MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. */
/* Use "i" anywhere in note symbol. */
/* 2.21 */
/* Increase from 20 to 30 dimensions for movement breaks and midi sections. */
/* Fix out-of-order declarations per mutex comments */
/* Add "Bad error" and "Kluging" messages to log file. */
/* 2.197 */
/* add /comips/ to save tie-check midi variables */
/* For spacing of clef changes at start of input block, changed integer time */
/* lastnodur to prevtn, so it works with xtups. Possible incompatibility! */
/* 2.196 */
/* Fix Ickbug with time check in ncmid() */
/* Interchange \fermataup7 and \pausec to get proper alignment */
/* Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. */
/* Add defn's of \hsp, \hspp to pmx.tex */
/* Fix pre-slurs on xtup chord notes. */
/* Fixed raised PAuse, define \liftPAuse */
/* Replace \zbreve\sk with \breve. */
/* Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what */
/* about "o" and 1 as shorthand for 16???? Search for "Kluge" */
/* Added "vo" (voice) as MIDI instrument 55 */
/* Allow 3-digit page numbers (search for "toppageno") */
/* Fix bug caused by prior fix (cancelling accid after bar line was ignored). */
/* Fix double accids in chords */
/* 2.194 */
/* Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if */
/* block. */
/* Add meter to MIDI file with every pause */
/* Purify FORTRAN? */
/* 2.193 */
/* Increased # of in-line TeX strings from 36 to 52. */
/* Fix entry of # of bytes in header of tempo/meter/key track to allow >255. */
/* 2.191 */
/* Event track: Tempos, meters, keys all together. Data in comevent */
/* 2.15 */
/* Pretty good midi capability. Still no attention to slurs on chord notes. */
/* 2.11 */
/* 11 Dec 99 c rm1 */
/* 11 Dec 99 "oes?", "oe?" */
/* 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes */
/* 11 Dec 99 Error message for shifted, repeated ornaments. */
/* 2.10 (Version 2.1) */
/* Fix bug with lowdot and xtuplets */
/* 2.09 */
/* Fix bug with multiple ornament heights over beams, when one is . or _ */
/* Error message from pmxa if rest on last note of xtup. */
/* Enable 12 slurs. */
/* Reinstate multiple rests at start of xtup. */
/* 2.07 */
/* Combine consecutive type-1 TeX strings. */
/* \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. */
/* Fixed breve chord notes in docrd */
/* Check irest(28) as well as vxtup when setting nodur for chord notes, since */
/* vxtup isn't set until 1st *main* note in xtup */
/* Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. */
/* 2.06+ */
/* Make deterministic the beam slope calculation when there are an even # of */
/* slopes in list and middle two are equal magnitude but opposite sign. */
/* pmxa Trap for "o:" before 1st note in block */
/* Partial bug fix for 64th notes in xtuplets. */
/* Make ixrest a vector, since with new time scheme may not finish xtup in */
/* same notes block. */
/* Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) */
/* 2.06 */
/* Account for changes in nv when computing \interstaff. Add a counter */
/* nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever */
/* setting isysflb(iflb). Note nv can only change at a forced line break. */
/* Note also, iflb starts at 0! */
/* 2.05 */
/* Automatic start of new notes group with part 2 of staff-jump beam */
/* In make1bar, set irest bit 29 of lowest-voice note at same time, */
/* use as flag when making notes groups. */
/* For now, remove dummy blank line at end...it zaps terminal repeats. */
/* 2.02 */
/* Fixed slur-counting bug for multiple, slurred, aftergraces. */
/* 2.01 */
/* Increase to ask(1400) */
/* Increase max forced page breaks to 18 */
/* Define pausc for centered pause */
/* 2.0a */
/* Insert dummy blank line at very end to handle input files w/o terminal CR-LF */
/* pmx03r */
/* Option m[n] in S symbol to change musicsize (for parts) */
/* Double dotted rests now work. */
/* Write file name to log file */
/* Check existence of input file */
/* Allow 24-char jobname, may end with ".pmx" */
/* Comment out time stuff */
/* Replace 3-argument getarg with 2-argument + iargc */
/* Fix bug with negative noinst due to nint<=int replacement */
/* move lovation of iv in isdat1 to allow iv>7. */
/* Set nm=12 */
/* pmx03q */
/* replace int(x+.001) with nint(x) */
/* Write TeX file name to screen and to pml. */
/* Replace char(...) with chax(...) to sovle msdev bug. */
/* Bug fix: macro terminations when M is on a line by itself. */
/* Bug fix: don't accumulate space for XS in pmxa. */
/* Streamline Macros: use pointers to bufq instead of scratch files */
/* pmx03p */
/* Store input file in single character array bufq. */
/* lbuf(i)*2 is length of line i */
/* ipbuf is position just before next line to be read. */
/* pmx03 */
/* Optimize read/writes */
/* pmx02 */
/* Fix line count (for errors) when there are saved macros */
/* pmx01 */
/* In optimize mode, open/close macros (Watch out for residual zz files!) */
/* Command line input */
/* Option Ao to optimize, otherwise normal processing */
/* cccccc */
/* Added 130302 only to get nsperi from g1etnote, for use in midi setup */
/* immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing */
/* nmidsec section starts and stops based on PLAYING macros (not recording). */
/* cccccccccccccccccccccccc */
/* cccccccccccccccccccccccc */
/* itstart = mytime() */
s_copy(comver_1.versionc, version, (ftnlen)5, (ftnlen)5);
/* Initialize midi parameters */
commmac_1.gottempo = FALSE_;
commidi_1.ismidi = FALSE_;
commidi_1.debugmidi = FALSE_;
commidi_1.relacc = FALSE_;
commmac_1.mmacrec = FALSE_;
commmac_1.nmidsec = 1;
commidi_1.mgap = 10;
comevent_1.miditime = 0;
comevent_1.lasttime = 0;
commidi_1.nmidcrd = 0;
comslm_1.nusebl = 0;
commidi_1.notmain = FALSE_;
for (ivx = 1; ivx <= 24; ++ivx) {
commidi_1.twoline[ivx - 1] = FALSE_;
commidi_1.midinst[ivx - 1] = 6;
commvel_1.midivel[ivx - 1] = 127;
commvel_1.midibal[ivx - 1] = 64;
commvel_1.miditran[ivx - 1] = 0;
/* L3: */
}
for (icm = 0; icm <= 24; ++icm) {
commidi_1.imidi[icm] = 0;
commidi_1.restpend[icm] = FALSE_;
commidi_1.trest[icm] = 0.f;
comslm_1.levson[icm] = 0;
comslm_1.levsoff[icm] = 0;
comslm_1.slmon[icm] = FALSE_;
comslm_1.naccbl[icm] = 0;
comdiag_1.n69[icm] = 0;
comdiag_1.n34[icm] = 0;
commmac_1.msecstrt[icm] = 1;
/* L12: */
}
/* End of midi parameter initialization */
commus_1.musize = 0;
optimize = FALSE_;
numargs = iargc_();
if (numargs == 0) {
s_wsle(&io___10);
do_lio(&c__9, &c__1, "You could have entered a jobname on the comman"
"d line,", (ftnlen)53);
e_wsle();
s_wsle(&io___11);
do_lio(&c__9, &c__1, " but you may enter one now:", (ftnlen)32);
e_wsle();
s_rsfe(&io___12);
do_fio(&c__1, jobname, (ftnlen)44);
e_rsfe();
numargs = 1;
} else {
/* call getarg(1,jobname,idum) ! May need to replace this w/ next line */
getarg_(&c__1, jobname, (ftnlen)44);
}
L10:
ljob = lenstr_(jobname, &c__44, (ftnlen)44);
if (ljob > 44) {
s_wsle(&io___15);
do_lio(&c__9, &c__1, "Jobname is too long. Try again.", (ftnlen)31);
e_wsle();
stop1_();
} else if (ljob == 0) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, "No was jobname entered. Try again.", (ftnlen)34)
;
e_wsle();
stop1_();
} else if (numargs == 2) {
if (ljob == 2 && s_cmp(jobname, "-o", (ftnlen)2, (ftnlen)2) == 0) {
optimize = TRUE_;
/* call getarg(2,jobname,idum) ! May need to replace this w/ next line */
getarg_(&c__2, jobname, (ftnlen)44);
numargs = 1;
goto L10;
} else {
s_wsle(&io___17);
do_lio(&c__9, &c__1, "Illegal option on command line", (ftnlen)30)
;
e_wsle();
stop1_();
}
}
/* Strip ".pmx" if necessary */
/* Computing MAX */
i__1 = i_indx(jobname, ".pmx", (ftnlen)44, (ftnlen)4), i__2 = i_indx(
jobname, ".PMX", (ftnlen)44, (ftnlen)4);
ndxpmx = max(i__1,i__2);
if (ndxpmx > 0) {
s_copy(jobname, jobname, (ftnlen)44, 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)47);
ioin__1.inerr = 0;
ioin__1.infilen = 47;
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) {
ioin__1.inerr = 0;
ioin__1.infilen = ljob + 4;
/* Writing concatenation */
i__3[0] = ljob, a__1[0] = jobname;
i__3[1] = 4, a__1[1] = ".PMX";
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48);
ioin__1.infile = ch__1;
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___21);
/* Writing concatenation */
i__3[0] = 17, a__1[0] = "Cannot find file ";
i__3[1] = 47, a__1[1] = infileq;
s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)64);
do_lio(&c__9, &c__1, ch__2, (ftnlen)64);
e_wsle();
stop1_();
} else {
/* 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)47);
}
}
/* Open a log file */
o__1.oerr = 0;
o__1.ounit = 15;
o__1.ofnmlen = ljob + 4;
/* Writing concatenation */
i__3[0] = ljob, a__1[0] = jobname;
i__3[1] = 4, a__1[1] = ".pml";
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
/* Writing concatenation */
i__4[0] = 21, a__2[0] = "This is PMX, Version ";
i__4[1] = 5, a__2[1] = version;
i__4[2] = 2, a__2[2] = ", ";
i__4[3] = 9, a__2[3] = date;
s_cat(ch__3, a__2, i__4, &c__4, (ftnlen)37);
printl_(ch__3, (ftnlen)37);
ljob4 = ljob;
/* Writing concatenation */
i__3[0] = 8, a__1[0] = "Opening ";
i__3[1] = 47, a__1[1] = infileq;
s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)55);
printl_(ch__4, (ftnlen)55);
o__1.oerr = 0;
o__1.ounit = 18;
o__1.ofnmlen = 47;
o__1.ofnm = infileq;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
/* Copy input file into common buffer */
inbuff_1.ipbuf = 0;
truelinecount_1.linewcom[0] = 1;
for (inbuff_1.ilbuf = 1; inbuff_1.ilbuf <= 4000; ++inbuff_1.ilbuf) {
ncomments = 0;
L14:
i__1 = s_rsfe(&io___24);
if (i__1 != 0) {
goto L9;
}
i__1 = do_fio(&c__1, lnholdq, (ftnlen)128);
if (i__1 != 0) {
goto L9;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L9;
}
inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) lenstr_(lnholdq, &
c__128, (ftnlen)128);
if (inbuff_1.lbuf[inbuff_1.ilbuf - 1] == 0) {
/* Blank line. Make it a single blank with length 1 */
inbuff_1.lbuf[inbuff_1.ilbuf - 1] = 1;
s_copy(lnholdq, " ", (ftnlen)128, (ftnlen)1);
}
/* Now line has at least one non blank character. Check for comment */
/* As of Version 260, do not copy comments into bufq */
/* But need to count %'s for error messaging */
/* if (lnholdq(1:1).eq.'%') go to 14 */
if (*(unsigned char *)lnholdq == '%') {
++ncomments;
goto L14;
}
/* When here, have counted all preceding comments and have a real line */
if (inbuff_1.ilbuf > 1) {
truelinecount_1.linewcom[inbuff_1.ilbuf - 1] =
truelinecount_1.linewcom[inbuff_1.ilbuf - 2] + 1 +
ncomments;
} else {
truelinecount_1.linewcom[0] = ncomments + 1;
}
if (inbuff_1.ipbuf + inbuff_1.lbuf[inbuff_1.ilbuf - 1] > 65536) {
s_wsle(&io___26);
do_lio(&c__9, &c__1, "Too many characters in file, stopping", (
ftnlen)37);
e_wsle();
stop1_();
}
i__1 = inbuff_1.ipbuf;
s_copy(inbuff_1.bufq + i__1, lnholdq, inbuff_1.ipbuf + inbuff_1.lbuf[
inbuff_1.ilbuf - 1] - i__1, (ftnlen)128);
inbuff_1.ipbuf += inbuff_1.lbuf[inbuff_1.ilbuf - 1];
/* L8: */
}
printl_("Too many lines in input file", (ftnlen)28);
stop1_();
L9:
/* Insert dummy line to handle input files w/o CR-LF at end. */
inbuff_1.nlbuf = inbuff_1.ilbuf - 1;
/* nlbuf = ilbuf */
/* bufq(ipbuf+1:ipbuf+3) = ' / ' */
/* lbuf(nlbuf) = 3 */
cl__1.cerr = 0;
cl__1.cunit = 18;
cl__1.csta = 0;
f_clos(&cl__1);
i__1 = maxit;
for (numit = 1; numit <= i__1; ++numit) {
if (optimize) {
printl_("Starting an iteration", (ftnlen)21);
}
/* When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. */
/* Otherwise, nbars0 is the input */
/* When islast=.false., pmxb only returns poe's, otherwise does whole job */
pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars0, &optimize, (ftnlen)
44);
if (! optimize) {
if (commidi_1.ismidi) {
/* This was moved here from writemidi 130302 to allow midivel,bal,tran, to be */
/* set up here as functions of instrument rather than iv (staff). */
/* Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv) */
nstaves = 0;
ivt = 0;
for (iinst = 1; iinst <= 24; ++iinst) {
nstaves += c1omget_1.nsperi[iinst - 1];
i__2 = c1omget_1.nsperi[iinst - 1];
for (ivtt = 1; ivtt <= i__2; ++ivtt) {
++ivt;
commvel_1.iinsiv[ivt - 1] = (shortint) iinst;
/* L17: */
}
if (nstaves == a1ll_1.nv) {
goto L18;
}
/* L16: */
}
s_wsle(&io___34);
do_lio(&c__9, &c__1, "Screwup!", (ftnlen)8);
e_wsle();
stop1_();
L18:
/* Set up channel numbers for midi. */
commidi_1.numchan = 0;
for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) {
if (commidi_1.twoline[a1ll_1.iv - 1]) {
commidi_1.midchan[a1ll_1.iv + 23] = commidi_1.numchan;
++commidi_1.numchan;
}
commidi_1.midchan[a1ll_1.iv - 1] = commidi_1.numchan;
++commidi_1.numchan;
/* L11: */
}
/* numchan will now be the number of channels, but max channel # is numchan-1 */
/* Set up velocities, balances, and midi-transpositions */
for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) {
if (commidi_1.twoline[a1ll_1.iv - 1]) {
/* 130302 Make these functions of instrument rather than staff (iv) */
/* midvelc(midchan(iv,2)) = midivel(iv) */
/* midbc(midchan(iv,2)) = midibal(iv) */
/* midtc(midchan(iv,2)) = miditran(iv) */
commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv + 23]] =
commvel_1.midivel[commvel_1.iinsiv[a1ll_1.iv
- 1] - 1];
commvel_1.midbc[commidi_1.midchan[a1ll_1.iv + 23]] =
commvel_1.midibal[commvel_1.iinsiv[a1ll_1.iv
- 1] - 1];
commvel_1.midtc[commidi_1.midchan[a1ll_1.iv + 23]] =
commvel_1.miditran[commvel_1.iinsiv[a1ll_1.iv
- 1] - 1];
}
/* midvelc(midchan(iv,1)) = midivel(iv) */
/* midbc(midchan(iv,1)) = midibal(iv) */
/* midtc(midchan(iv,1)) = miditran(iv) */
commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv - 1]] =
commvel_1.midivel[commvel_1.iinsiv[a1ll_1.iv - 1]
- 1];
commvel_1.midbc[commidi_1.midchan[a1ll_1.iv - 1]] =
commvel_1.midibal[commvel_1.iinsiv[a1ll_1.iv - 1]
- 1];
commvel_1.midtc[commidi_1.midchan[a1ll_1.iv - 1]] =
commvel_1.miditran[commvel_1.iinsiv[a1ll_1.iv - 1]
- 1];
/* L13: */
}
}
/* TEMPORARY!!! */
s_wsle(&io___35);
do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7);
do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof(
integer));
e_wsle();
ip1 = 1;
i__2 = inbuff_1.nlbuf;
for (ilb = 1; ilb <= i__2; ++ilb) {
/* write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), */
/* * bufq(ip1:ip1+lbuf(ilb)-1), */
/* * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), */
/* * k=min(3,lbuf(ilb)),1,-1) */
ip1 += inbuff_1.lbuf[ilb - 1];
/* L10000: */
}
iplast = ip1 - 1;
/* Check to see if (1) last line is "/" and (2) next to last */
/* line is "/" */
/* print*,'iplast:',iplast */
/* print*,'Last line:' */
/* print*,bufq(iplast+1-lbuf(nlbuf):iplast) */
/* print*,'Last char of next to last line:' */
/* print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) */
i__2 = iplast + 1 - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1;
if (s_cmp(inbuff_1.bufq + i__2, " /", iplast - i__2, (ftnlen)3)
== 0) {
i__2 = iplast - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1;
if (s_cmp(inbuff_1.bufq + i__2, "/", iplast - inbuff_1.lbuf[
inbuff_1.nlbuf - 1] - i__2, (ftnlen)1) == 0) {
s_wsle(&io___39);
do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39);
e_wsle();
s_wsle(&io___40);
do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39);
e_wsle();
--inbuff_1.nlbuf;
}
}
pmxb_(&c_true, poe0, &ncalls, &optimize);
if (commidi_1.ismidi) {
/* Write midi file */
o__1.oerr = 0;
o__1.ounit = 51;
o__1.ofnmlen = ljob + 4;
/* Writing concatenation */
i__3[0] = ljob, a__1[0] = jobname;
i__3[1] = 4, a__1[1] = ".mid";
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
if (commidi_1.debugmidi) {
o__1.oerr = 0;
o__1.ounit = 52;
o__1.ofnmlen = ljob + 4;
/* Writing concatenation */
i__3[0] = ljob, a__1[0] = jobname;
i__3[1] = 4, a__1[1] = ".dbm";
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
}
printl_(" ", (ftnlen)1);
/* Writing concatenation */
i__5[0] = 8, a__3[0] = "Writing ";
i__5[1] = ljob, a__3[1] = jobname;
i__5[2] = 4, a__3[2] = ".mid";
s_cat(ch__5, a__3, i__5, &c__3, (ftnlen)56);
printl_(ch__5, ljob + 12);
writemidi_(jobname, &ljob, (ftnlen)44);
}
cl__1.cerr = 0;
cl__1.cunit = 15;
cl__1.csta = 0;
f_clos(&cl__1);
s_stop("", (ftnlen)0);
}
s_wsle(&io___42);
do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7);
do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof(integer))
;
e_wsle();
ip1 = 1;
pmxb_(&c_false, poe0, &ncalls, &optimize);
poestats_(&nsyst, poe0, &poebar0, &devnorm0);
/* Save initial deviation and line breaks for later comparison */
if (numit == 1) {
devpmx = devnorm0;
i__2 = nsyst;
for (isys = 1; isys <= i__2; ++isys) {
nbari[isys - 1] = nbars0[isys - 1];
/* L20: */
}
}
sortpoe_(&nsyst, poe0, ipoe);
for (iupord = nsyst; iupord >= 1; --iupord) {
isysu = ipoe[iupord - 1];
s_wsle(&io___51);
do_lio(&c__9, &c__1, "isysu=", (ftnlen)6);
do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___52);
do_lio(&c__9, &c__1, "isysu=", (ftnlen)6);
do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer));
e_wsle();
/* Skip if system isysu has poe0 < avg or isysd has poe0 > avg */
if (poe0[isysu - 1] < poebar0) {
goto L1;
}
i__2 = nsyst;
for (idnord = 1; idnord <= i__2; ++idnord) {
isysd = ipoe[idnord - 1];
if (isysu == isysd || nbars0[isysd - 1] == 1 || poe0[isysd -
1] > poebar0) {
goto L5;
}
i__6 = nsyst;
for (isyst = 1; isyst <= i__6; ++isyst) {
nbars[isyst - 1] = nbars0[isyst - 1];
if (isyst == isysu) {
++nbars[isyst - 1];
} else if (isyst == isysd) {
--nbars[isyst - 1];
}
/* L2: */
}
pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars, &optimize, (
ftnlen)44);
pmxb_(&c_false, poe, &ncalls, &optimize);
poestats_(&nsyst, poe, &poebar, &devnorm);
if (devnorm < devnorm0) {
devnorm0 = devnorm;
poebar0 = poebar;
i__6 = nsyst;
for (isys = 1; isys <= i__6; ++isys) {
nbars0[isys - 1] = nbars[isys - 1];
poe0[isys - 1] = poe[isys - 1];
/* L4: */
}
s_wsle(&io___60);
do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", (
ftnlen)32);
do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof(
integer));
do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(
real));
e_wsle();
s_wsle(&io___61);
do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", (
ftnlen)32);
do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof(
integer));
do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(
real));
e_wsle();
s_wsfe(&io___62);
i__6 = nsyst;
for (isys = 1; isys <= i__6; ++isys) {
do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)
sizeof(integer));
}
e_wsfe();
s_wsfe(&io___63);
i__6 = nsyst;
for (isys = 1; isys <= i__6; ++isys) {
do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)
sizeof(integer));
}
e_wsfe();
sortpoe_(&nsyst, poe0, ipoe);
goto L6;
}
L5:
;
}
L1:
;
}
/* If we get here, must have gone thru all switches and found nothing better, */
/* so done! */
goto L7;
L6:
;
}
L7:
s_wsle(&io___64);
do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23);
do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10);
do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___65);
do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23);
do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10);
do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___66);
do_lio(&c__9, &c__1, "Final error:", (ftnlen)12);
do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real));
do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16);
do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___67);
do_lio(&c__9, &c__1, "Final error:", (ftnlen)12);
do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real));
do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16);
do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___68);
do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23);
r__1 = (1 - devnorm0 / devpmx) * 100.f;
do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___69);
do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23);
r__1 = (1 - devnorm0 / devpmx) * 100.f;
do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsle();
printl_("Initial bars/system:", (ftnlen)20);
s_wsfe(&io___70);
i__1 = nsyst;
for (isys = 1; isys <= i__1; ++isys) {
do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___71);
i__1 = nsyst;
for (isys = 1; isys <= i__1; ++isys) {
do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
printl_("Final bars/system:", (ftnlen)18);
s_wsfe(&io___72);
i__1 = nsyst;
for (isys = 1; isys <= i__1; ++isys) {
do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___73);
i__1 = nsyst;
for (isys = 1; isys <= i__1; ++isys) {
do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
pmxa_(jobname, &ljob4, &c_false, &nsyst, nbars0, &optimize, (ftnlen)44);
pmxb_(&c_true, poe0, &ncalls, &optimize);
/* itend = mytime() */
/* print*,'Elapsed time in ms:',itend-itstart */
/* write(15,*)'Elapsed time in ms:',itend-itstart */
cl__1.cerr = 0;
cl__1.cunit = 15;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* MAIN__ */
/* Subroutine */ int accsym_(integer *nacc, char *acsymq, integer *lacc,
ftnlen acsymq_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
static integer iacc;
/* Fortran I/O blocks */
static cilist io___75 = { 0, 6, 0, 0, 0 };
iacc = *nacc & 7;
if (iacc == 1) {
s_copy(acsymq, "fl", (ftnlen)3, (ftnlen)2);
*lacc = 2;
} else if (iacc == 2) {
s_copy(acsymq, "sh", (ftnlen)3, (ftnlen)2);
*lacc = 2;
} else if (iacc == 3) {
s_copy(acsymq, "na", (ftnlen)3, (ftnlen)2);
*lacc = 2;
} else if (iacc == 5) {
s_copy(acsymq, "dfl", (ftnlen)3, (ftnlen)3);
*lacc = 3;
} else if (iacc == 6) {
s_copy(acsymq, "dsh", (ftnlen)3, (ftnlen)3);
*lacc = 3;
} else {
s_wsle(&io___75);
do_lio(&c__9, &c__1, "bad accidental: ", (ftnlen)16);
do_lio(&c__3, &c__1, (char *)&iacc, (ftnlen)sizeof(integer));
e_wsle();
}
return 0;
} /* accsym_ */
/* Subroutine */ int addask_(real *taskn, real *waskn, real *elaskn, real *
fixednew, real *scaldold, real *tglp1, logical *isudsp)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
static real oldelask;
extern /* Subroutine */ int stop1_(void);
static integer iudsp;
static real oldwask;
/* Fortran I/O blocks */
static cilist io___77 = { 0, 6, 0, 0, 0 };
if (*isudsp) {
/* Find which udsp we're dealing with */
i__1 = comudsp_1.nudsp;
for (iudsp = 1; iudsp <= i__1; ++iudsp) {
if ((r__1 = *taskn + *tglp1 - comudsp_1.tudsp[iudsp - 1], dabs(
r__1)) < comtol_1.tol) {
goto L2;
}
/* L1: */
}
s_wsle(&io___77);
do_lio(&c__9, &c__1, "You should note BEEE here in addask!", (ftnlen)
36);
e_wsle();
stop1_();
L2:
/* Fixednew and scaldold must not be changed, since udsp's are already included */
/* in fsyst from pmxa, and udsp don't involve scaled space.. */
if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1,
comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) {
/* Must add user-defined space to what's there already. */
comas1_1.wask[comas1_1.naskb - 1] += comudsp_1.udsp[iudsp - 1];
} else {
/* This place has no other space. */
++comas1_1.naskb;
comas1_1.task[comas1_1.naskb - 1] = *taskn;
comas1_1.wask[comas1_1.naskb - 1] = comudsp_1.udsp[iudsp - 1];
comas1_1.elask[comas1_1.naskb - 1] = 0.f;
}
} else {
/* 130330 start */
oldwask = 0.f;
oldelask = 0.f;
/* 130330 end */
/* This is a normal space, no effect if smaller than existing space */
if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1,
comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) {
/* We already put in some space at this time */
/* Check if new one needs more space than old one at same time */
if (*waskn > comas1_1.wask[comas1_1.naskb - 1]) {
/* 130330 We were double counting the larger space when it came 2nd */
/* Need to fix but don't see how yet. Assume times came in order and */
/* that last naskb defined spaces that need updating */
oldwask = comas1_1.wask[comas1_1.naskb - 1];
oldelask = comas1_1.elask[comas1_1.naskb - 1];
/* End of 130330 insertions */
--comas1_1.naskb;
} else {
return 0;
}
}
++comas1_1.naskb;
comas1_1.task[comas1_1.naskb - 1] = *taskn;
comas1_1.wask[comas1_1.naskb - 1] = *waskn;
comas1_1.elask[comas1_1.naskb - 1] = *elaskn;
/* 130330 start */
/* fixednew = fixednew+waskn */
/* scaldold = scaldold+elaskn */
*fixednew = *fixednew + *waskn - oldwask;
*scaldold = *scaldold + *elaskn - oldelask;
/* 130330 end */
}
return 0;
} /* addask_ */
/* Subroutine */ int addblank_(char *noteq, integer *lnoten, ftnlen noteq_len)
{
/* System generated locals */
address a__1[2];
integer i__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
static char tchar[1];
s_copy(tchar, noteq, (ftnlen)1, (ftnlen)8);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = " ";
i__1[1] = 1, a__1[1] = tchar;
s_cat(noteq, a__1, i__1, &c__2, (ftnlen)8);
*lnoten = 2;
return 0;
} /* addblank_ */
/* Subroutine */ int addfb_(integer *nfb, integer *iv, real *tnew, real *t1fb,
real *t2fb, char *ulfbq, integer *ifbadd, ftnlen ulfbq_len)
{
static integer ifb;
/* Parameter adjustments */
ulfbq -= 25;
t2fb -= 25;
t1fb -= 25;
--nfb;
/* Function Body */
*ifbadd = 1;
++nfb[*iv];
for (ifb = nfb[*iv] - 1; ifb >= 1; --ifb) {
if (*tnew < t1fb[*iv + ifb * 24] - comtol_1.tol) {
t1fb[*iv + (ifb + 1) * 24] = t1fb[*iv + ifb * 24];
t2fb[*iv + (ifb + 1) * 24] = t2fb[*iv + ifb * 24];
*(unsigned char *)&ulfbq[*iv + (ifb + 1) * 24] = *(unsigned char *
)&ulfbq[*iv + ifb * 24];
} else {
*ifbadd = ifb + 1;
goto L2;
}
/* L1: */
}
L2:
t1fb[*iv + *ifbadd * 24] = *tnew;
*(unsigned char *)&ulfbq[*iv + *ifbadd * 24] = 'x';
return 0;
} /* addfb_ */
/* Subroutine */ int addmidi_(integer *icm, integer *nolev, integer *iacc,
integer *midisig, real *time, logical *rest, logical *endrest)
{
/* Initialized data */
static shortint icmm[16] = { 0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16 };
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
/* Builtin functions */
integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *,
char *, ftnlen), e_wsle(void), i_indx(char *, char *, ftnlen,
ftnlen);
/* Local variables */
static logical it1found;
static integer nsav4tie;
extern /* Subroutine */ int chkimidi_(integer *);
static char notenumq[1];
static integer i__, j, it1;
extern integer igetvarlen_(shortint *, integer *, integer *, integer *);
static integer it2;
extern integer isetvarlen_(integer *, integer *);
static integer ion;
static shortint itk[25];
static integer jacc, kacc, macc, ioff, isav, idur, jsav, idur1;
extern /* Subroutine */ int stop1_(void);
static integer imidt, ipsav, ipsav0, nby2on;
extern integer iashft_(integer *);
static integer nbytes;
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer nby2off;
static logical eximacc;
static integer itiesav[500] /* was [5][100] */, idurvar;
/* Fortran I/O blocks */
static cilist io___87 = { 0, 6, 0, 0, 0 };
static cilist io___99 = { 0, 6, 0, 0, 0 };
/* subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) */
/* common /commidisig/ midisig(nm) */
/* Following variables are local but must be saved. I hope they are. */
/* (3/18/00) With g77 they are not, so add a common block here. */
/* integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) */
/* data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ */
/* Cancel out barline accidentals if there's a rest. */
if (*rest) {
comslm_1.naccbl[(300 + (0 + (*icm - 0 << 2)) - 300) / 4] = 0;
}
/* Special path to insert dummy rest at end of a section */
if (*endrest) {
goto L20;
}
i__1 = commidi_1.nmidcrd;
for (ion = 0; ion <= i__1; ++ion) {
/* check if this is only to get pitch of a chord note */
if (commidi_1.notmain) {
goto L6;
}
/* check for rest */
if (*rest) {
/* Will not put in a note, but must update timing */
if (! commidi_1.restpend[*icm]) {
/* First rest in sequence, save the time */
commidi_1.restpend[*icm] = TRUE_;
commidi_1.trest[*icm] = *time;
} else {
commidi_1.trest[*icm] += *time;
}
/* Note: code checkers don't like the above due to calling addmidi(trest(icm)) */
/* but this only happens if rest at end of section (endrest=.true.) (called */
/* from getmidi(), in which case these above lines are bypassed. */
chkimidi_(icm);
return 0;
}
/* time tics */
if (commidi_1.imidi[*icm] > 0 && ion == 0) {
idur = commidi_1.mgap;
} else {
idur = 0;
}
if (commidi_1.restpend[*icm]) {
commidi_1.restpend[*icm] = FALSE_;
r__1 = commidi_1.trest[*icm] * 15;
idur += i_nint(&r__1);
}
/* time to start of note */
idurvar = isetvarlen_(&idur, &nby2on);
if (nby2on > 4) {
s_wsle(&io___87);
do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.", (
ftnlen)37);
e_wsle();
stop1_();
}
++commidi_1.imidi[*icm];
i__2 = nby2on;
for (i__ = 1; i__ <= i__2; ++i__) {
/* imidi points to cell before highest (leftmost) byte. Start with lowest byte */
/* at far right, fill in backwards */
commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2on - i__) *
25 - 25] = (shortint) (idurvar % 256);
if (nby2on > 1) {
idurvar /= 256;
}
/* L2: */
}
commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2on - 1;
/* Note-on signal */
++commidi_1.imidi[*icm];
/* mmidi(icm,imidi(icm)) = 9*16+icm */
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) (
icmm[*icm] + 144);
/* Entry point for chord note pitch determination */
L6:
/* Get midi pitch. On chord iteration, only do this first time (main note), */
/* since pitch was already computed for nonmain chord notes. */
if (ion == 0) {
ipsav = *nolev * 12.f / 7 + 11;
ipsav0 = ipsav;
if (*midisig != 0) {
/* Adjust for signature */
*(unsigned char *)notenumq = (char) (*nolev % 7 + 48);
if (*midisig >= i_indx("4152630", notenumq, (ftnlen)7, (
ftnlen)1)) {
++ipsav;
} else if (-(*midisig) >= i_indx("0362514", notenumq, (ftnlen)
7, (ftnlen)1)) {
--ipsav;
}
}
/* Deal with accidentals. */
/* iacc 0 1 2 3 4 5 6 7 */
/* effect X fl sh na X dfl dsh X */
/* iashft X -1 1 0 X -2 2 X */
jacc = 0;
eximacc = FALSE_;
if (*iacc > 0) {
/* Adjust key-sig-adjusted pitch for explicit accidental (and exit) */
jacc = iashft_(iacc);
eximacc = TRUE_;
if (! commidi_1.relacc) {
jacc = jacc + ipsav0 - ipsav;
}
/* (Above) Shift applies to diatonic pitch but will be added to adjusted one */
} else if (commidi_1.naccim[*icm] > 0) {
/* Possible implicit accidental from earlier in the bar */
/* Check for prior accid in this bar at this note level */
i__2 = commidi_1.naccim[*icm];
for (kacc = 1; kacc <= i__2; ++kacc) {
if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) {
jacc = commidi_1.jaccim[*icm + kacc * 25 - 25];
eximacc = TRUE_;
if (! commidi_1.relacc) {
jacc = jacc + ipsav0 - ipsav;
}
goto L4;
}
/* L3: */
}
L4:
;
}
/* Must split off the following if block from those above because chord */
/* notes can cause naccim>0, forcing us to miss other chord note's */
/* accross-bar-line accidental */
if (comslm_1.naccbl[*icm] > 0 && ! eximacc) {
/* Possible carryover accid from prior bar (or prior same-pitch note). */
i__2 = comslm_1.naccbl[*icm];
for (kacc = 1; kacc <= i__2; ++kacc) {
if (comslm_1.laccbl[*icm + kacc * 25 - 25] == *nolev) {
jacc = comslm_1.jaccbl[*icm + kacc * 25 - 25];
/* Since we are *using* the bar-line accid, must flag it to be saved for next. */
++comslm_1.nusebl;
comips_1.jusebl[comslm_1.nusebl - 1] = (shortint)
jacc;
comips_1.lusebl[comslm_1.nusebl - 1] = (shortint) (*
nolev);
if (! commidi_1.relacc) {
jacc = jacc + ipsav0 - ipsav;
}
goto L22;
}
/* L21: */
}
L22:
;
}
ipsav += jacc;
}
if (commidi_1.notmain) {
commidi_1.mcpitch[commidi_1.nmidcrd - 1] = ipsav;
/* Save pitch for tie checks */
if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm]) {
comips_1.ipslon[*icm] = (shortint) ipsav;
}
} else {
++commidi_1.imidi[*icm];
if (ion == 0) {
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (
shortint) ipsav;
if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm])
{
comips_1.ipslon[*icm] = (shortint) ipsav;
}
} else {
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (
shortint) commidi_1.mcpitch[ion - 1];
}
}
if (ion == 0) {
/* Only record accids for non-chords, main chord note during chord iteration */
/* and chordnotes on first call but not during iteration */
if (*iacc > 0) {
/* Set marker for accidental for possible continuations later this bar */
/* but first check and clear earlier ones on same note. */
i__2 = commidi_1.naccim[*icm];
for (kacc = 1; kacc <= i__2; ++kacc) {
if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) {
i__3 = commidi_1.naccim[*icm] - 1;
for (macc = kacc; macc <= i__3; ++macc) {
commidi_1.laccim[*icm + macc * 25 - 25] =
commidi_1.laccim[*icm + (macc + 1) * 25 -
25];
commidi_1.jaccim[*icm + macc * 25 - 25] =
commidi_1.jaccim[*icm + (macc + 1) * 25 -
25];
/* L24: */
}
goto L25;
}
/* L23: */
}
goto L26;
L25:
--commidi_1.naccim[*icm];
L26:
/* Flag new accidental */
++commidi_1.naccim[*icm];
commidi_1.laccim[*icm + commidi_1.naccim[*icm] * 25 - 25] = *
nolev;
commidi_1.jaccim[*icm + commidi_1.naccim[*icm] * 25 - 25] =
iashft_(iacc);
}
/* Bail if this is a chord note on the first call (from docrd) */
if (commidi_1.notmain) {
chkimidi_(icm);
return 0;
}
}
/* Vel */
++commidi_1.imidi[*icm];
/* mmidi(icm,imidi(icm)) = 127 */
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint)
commvel_1.midvelc[*icm];
chkimidi_(icm);
/* L7: */
}
/* For tie checks */
if (comslm_1.levson[*icm] > 0 && ! comslm_1.slmon[*icm]) {
comslm_1.imidso[*icm] = commidi_1.imidi[*icm];
}
/* Entry point for special rests at section ends (endrest=T) */
L20:
/* Now insert all the ends */
i__1 = commidi_1.nmidcrd;
for (ioff = 0; ioff <= i__1; ++ioff) {
if (ioff == 0) {
/* time to end */
r__1 = *time * 15;
idur1 = i_nint(&r__1);
r__1 = commidi_1.trest[*icm] * 15;
if (! (*endrest) || comevent_1.miditime == i_nint(&r__1)) {
idur = idur1 - commidi_1.mgap;
} else {
idur = idur1;
}
/* Deal with roundoff problems with 7-tuplets on half or quarters */
if (idur1 == 69) {
++comdiag_1.n69[*icm];
/* if (mod(n69(icm)+6,7) .gt. 3) idur = 58 */
if ((comdiag_1.n69[*icm] + 6) % 7 > 3) {
idur = idur1 - commidi_1.mgap - 1;
}
} else if (idur1 == 34) {
++comdiag_1.n34[*icm];
if ((comdiag_1.n34[*icm] + 6) % 7 > 4) {
idur = idur1 - commidi_1.mgap + 1;
}
}
idurvar = isetvarlen_(&idur, &nby2off);
if (nby2off > 4) {
s_wsle(&io___99);
do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.",
(ftnlen)37);
e_wsle();
stop1_();
}
++commidi_1.imidi[*icm];
chkimidi_(icm);
i__2 = nby2off;
for (i__ = 1; i__ <= i__2; ++i__) {
commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2off - i__)
* 25 - 25] = (shortint) (idurvar % 256);
if (nby2off > 1) {
idurvar /= 256;
}
/* L1: */
}
commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2off - 1;
} else {
/* Inserting end of chord note, delta time is 0 */
++commidi_1.imidi[*icm];
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0;
}
/* Note off */
++commidi_1.imidi[*icm];
/* mmidi(icm,imidi(icm)) = 8*16+icm */
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) (
icmm[*icm] + 128);
/* Pitch */
++commidi_1.imidi[*icm];
if (ioff == 0) {
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (
shortint) ipsav;
} else {
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (
shortint) commidi_1.mcpitch[ioff - 1];
}
/* Vel */
++commidi_1.imidi[*icm];
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0;
chkimidi_(icm);
if (*endrest) {
return 0;
}
/* print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time */
/* L8: */
}
comslm_1.naccbl[*icm] = comslm_1.nusebl;
if (comslm_1.nusebl > 0) {
/* Fix tables of "bar-line" accids that are saved due to consecutive notes. */
i__1 = comslm_1.nusebl;
for (kacc = 1; kacc <= i__1; ++kacc) {
comslm_1.laccbl[*icm + kacc * 25 - 25] = comips_1.lusebl[kacc - 1]
;
comslm_1.jaccbl[*icm + kacc * 25 - 25] = comips_1.jusebl[kacc - 1]
;
/* L30: */
}
comslm_1.nusebl = 0;
}
/* Begin tie checks */
if (comslm_1.slmon[*icm]) {
/* Prior note had a slur start */
if (comslm_1.levson[*icm] == comslm_1.levsoff[*icm] && *iacc == 0) {
/* We have a tie! (Assumed there would be no accidental on tie-ending note) */
/* Make a list of times of all events back to the one starting at imidso+1, */
/* which is at or before where the tie started. Ident tie start and stop by */
/* comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) */
/* Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial */
/* time. */
nsav4tie = 0;
imidt = comslm_1.imidso[*icm];
L10:
++nsav4tie;
itiesav[nsav4tie * 5 - 5] = igetvarlen_(commidi_1.mmidi, icm, &
imidt, &nbytes);
imidt += nbytes;
for (j = 1; j <= 3; ++j) {
itiesav[j + 1 + nsav4tie * 5 - 6] = commidi_1.mmidi[*icm + (
imidt + j) * 25 - 25];
/* L11: */
}
imidt += 3;
if (nsav4tie == 1) {
itiesav[4] = itiesav[0];
} else {
itiesav[nsav4tie * 5 - 1] = itiesav[nsav4tie * 5 - 5] +
itiesav[(nsav4tie - 1) * 5 - 1];
}
if (imidt != commidi_1.imidi[*icm]) {
goto L10;
}
/* Find which two pitches agree with saved slur pitch. */
it1found = FALSE_;
i__1 = nsav4tie;
for (it2 = 1; it2 <= i__1; ++it2) {
if (itiesav[it2 * 5 - 3] == comips_1.ipslon[*icm]) {
if (it1found) {
goto L13;
}
it1 = it2;
it1found = TRUE_;
}
/* L12: */
}
printl_("Program error, tied notes, send source to Dr. Don", (
ftnlen)49);
it1 = nsav4tie + 1;
it2 = nsav4tie + 1;
L13:
/* List the positions we want to keep */
jsav = 0;
i__1 = nsav4tie;
for (isav = 1; isav <= i__1; ++isav) {
if (isav == it1 || isav == it2) {
goto L14;
}
++jsav;
itk[jsav - 1] = (shortint) isav;
L14:
;
}
nsav4tie += -2;
/* Now dump events it1 & it2, recompute times, restack mmidi. */
commidi_1.imidi[*icm] = comslm_1.imidso[*icm];
i__1 = nsav4tie;
for (isav = 1; isav <= i__1; ++isav) {
if (isav == 1) {
idurvar = isetvarlen_(&itiesav[itk[isav - 1] * 5 - 1], &
nbytes);
} else {
i__2 = itiesav[itk[isav - 1] * 5 - 1] - itiesav[itk[isav
- 2] * 5 - 1];
idurvar = isetvarlen_(&i__2, &nbytes);
}
++commidi_1.imidi[*icm];
i__2 = nbytes;
for (i__ = 1; i__ <= i__2; ++i__) {
commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nbytes -
i__) * 25 - 25] = (shortint) (idurvar % 256);
if (nbytes > 1) {
idurvar /= 256;
}
/* L16: */
}
commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nbytes - 1;
for (i__ = 2; i__ <= 4; ++i__) {
++commidi_1.imidi[*icm];
commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] =
(shortint) itiesav[i__ + itk[isav - 1] * 5 - 6];
/* L17: */
}
/* L15: */
}
}
comslm_1.slmon[*icm] = FALSE_;
comslm_1.levsoff[*icm] = 0;
if (! comslm_1.dbltie) {
comslm_1.levson[*icm] = 0;
}
}
if (comslm_1.levson[*icm] > 0) {
comslm_1.slmon[*icm] = TRUE_;
}
if (commidi_1.nmidcrd > 0) {
commidi_1.nmidcrd = 0;
}
chkimidi_(icm);
return 0;
} /* addmidi_ */
/* Subroutine */ int addstr_(char *notexq, integer *lnote, char *soutq,
integer *lsout, ftnlen notexq_len, ftnlen soutq_len)
{
/* System generated locals */
address a__1[2];
integer i__1[2];
char ch__1[81];
/* Builtin functions */
integer s_wsfe(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___111 = { 0, 11, 0, "(a)", 0 };
if (*lsout + *lnote > 72) {
if (comlast_1.islast) {
s_wsfe(&io___111);
/* Writing concatenation */
i__1[0] = *lsout, a__1[0] = soutq;
i__1[1] = 1, a__1[1] = "%";
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)81);
do_fio(&c__1, ch__1, *lsout + 1);
e_wsfe();
}
*lsout = 0;
}
if (*lsout > 0) {
/* Writing concatenation */
i__1[0] = *lsout, a__1[0] = soutq;
i__1[1] = *lnote, a__1[1] = notexq;
s_cat(soutq, a__1, i__1, &c__2, (ftnlen)80);
} else {
s_copy(soutq, notexq, (ftnlen)80, (*lnote));
}
*lsout += *lnote;
return 0;
} /* addstr_ */
/* Subroutine */ int adjusteskz_(integer *ib, real *squez, integer *istart,
integer *istop, real *poenom)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Local variables */
static integer in, iaskb, inmin;
static real eskadd;
/* For block ib, this adds accidental spaces to eskz, for use in getting */
/* length of xtup bracket and slopes of brackets and beams. */
/* Parameter adjustments */
--istop;
--istart;
--squez;
/* Function Body */
inmin = istart[*ib] + 1;
i__1 = comas1_1.naskb;
for (iaskb = 1; iaskb <= i__1; ++iaskb) {
if (comas1_1.task[iaskb - 1] < all_1.to[istart[*ib] - 1] -
comtol_1.tol) {
goto L10;
}
eskadd = comas1_1.wask[iaskb - 1] / *poenom - comas1_1.elask[iaskb -
1];
i__2 = comntot_1.ntot;
for (in = inmin; in <= i__2; ++in) {
if (all_1.to[in - 1] > comas1_1.task[iaskb - 1] - comtol_1.tol) {
comeskz2_1.eskz2[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24
- 25] += eskadd;
if ((r__1 = all_1.to[in - 1] - comas1_1.task[iaskb - 1], dabs(
r__1)) < comtol_1.tol) {
--inmin;
}
} else {
++inmin;
}
/* L11: */
}
L10:
;
}
return 0;
} /* adjusteskz_ */
/* Subroutine */ int askfig_(char *pathnameq, integer *lpath, char *basenameq,
integer *lbase, logical *figbass, logical *istype0, ftnlen
pathnameq_len, ftnlen basenameq_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1[3], i__2[2], i__3;
char ch__1[1], ch__2[88], ch__3[15], ch__4[5], ch__5[4];
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer f_open(olist *), f_rew(alist *), f_clos(cllist *), s_wsfe(cilist *
), do_fio(integer *, char *, ftnlen), e_wsfe(void), s_rsfe(cilist
*), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen), s_wsfi(
icilist *), e_wsfi(void), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer il;
static char sq[1];
static integer ihs;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static logical done;
extern integer llen_(char *, integer *, ftnlen);
static char outq[129];
extern /* Subroutine */ int moveln_(integer *, integer *, logical *);
static integer lenout;
extern /* Subroutine */ int putast_(real *, integer *, char *, ftnlen);
static integer indxask;
/* Fortran I/O blocks */
static cilist io___119 = { 0, 12, 0, "(a)", 0 };
static cilist io___120 = { 0, 12, 0, "(a)", 0 };
static cilist io___122 = { 0, 11, 1, "(a129)", 0 };
static icilist io___124 = { 0, outq+11, 0, "(f4.1)", 4, 1 };
static cilist io___127 = { 0, 12, 0, "(a)", 0 };
static cilist io___128 = { 0, 16, 1, "(a129)", 0 };
static cilist io___129 = { 0, 12, 0, "(a)", 0 };
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
o__1.oerr = 0;
o__1.ounit = 12;
o__1.ofnmlen = *lpath + *lbase + 4;
/* Writing concatenation */
i__1[0] = *lpath, a__1[0] = pathnameq;
i__1[1] = *lbase, a__1[1] = basenameq;
i__1[2] = 4, a__1[2] = ".tex";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)88);
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);
/* Transfer first 5 lines of main internal TeX file */
for (il = 1; il <= 5; ++il) {
moveln_(&c__11, &c__12, &done);
/* L11: */
}
if (*istype0) {
/* Transfer literal TeX stuff from special scratch file */
al__1.aerr = 0;
al__1.aunit = 17;
f_rew(&al__1);
L10:
moveln_(&c__17, &c__12, &done);
if (! done) {
goto L10;
}
cl__1.cerr = 0;
cl__1.cunit = 17;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* Transfer next 2 lines from main scratch file */
for (il = 1; il <= 2; ++il) {
moveln_(&c__11, &c__12, &done);
/* L3: */
}
if (compoi_1.ispoi) {
s_wsfe(&io___119);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 14, a__2[1] = "input musixpoi";
s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15);
do_fio(&c__1, ch__3, (ftnlen)15);
e_wsfe();
}
if (combbm_1.isbbm) {
s_wsfe(&io___120);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 14, a__2[1] = "input musixbbm";
s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15);
do_fio(&c__1, ch__3, (ftnlen)15);
e_wsfe();
}
if (*figbass) {
/* Transfer .fig data from scratch (unit 14) into external .tex (unit 12) */
L4:
moveln_(&c__14, &c__12, &done);
if (! done) {
goto L4;
}
cl__1.cerr = 0;
cl__1.cunit = 14;
cl__1.csta = 0;
f_clos(&cl__1);
}
comas3_1.iask = 0;
ihs = 0;
L1:
i__3 = s_rsfe(&io___122);
if (i__3 != 0) {
goto L999;
}
i__3 = do_fio(&c__1, outq, (ftnlen)129);
if (i__3 != 0) {
goto L999;
}
i__3 = e_rsfe();
if (i__3 != 0) {
goto L999;
}
/* Hardspaces. */
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 4, a__2[1] = "xard";
s_cat(ch__4, a__2, i__2, &c__2, (ftnlen)5);
if (s_cmp(outq, ch__4, (ftnlen)5, (ftnlen)5) == 0) {
++ihs;
*(unsigned char *)&outq[1] = 'h';
s_wsfi(&io___124);
do_fio(&c__1, (char *)&comhsp_1.hpttot[ihs - 1], (ftnlen)sizeof(real))
;
e_wsfi();
lenout = 19;
goto L9;
}
/* This part hard-wires ask's into new .tex file as ast's */
L2:
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 3, a__2[1] = "ask";
s_cat(ch__5, a__2, i__2, &c__2, (ftnlen)4);
indxask = i_indx(outq, ch__5, (ftnlen)129, (ftnlen)4);
if (indxask != 0) {
++comas3_1.iask;
putast_(&comas3_1.ask[comas3_1.iask - 1], &indxask, outq, (ftnlen)129)
;
goto L2;
}
lenout = llen_(outq, &c__129, (ftnlen)129);
L9:
s_wsfe(&io___127);
do_fio(&c__1, outq, lenout);
e_wsfe();
/* If this is the line with "readmod", check for topmods. */
if (comas3_1.topmods && s_cmp(outq + 1, "readmod", (ftnlen)7, (ftnlen)7)
== 0) {
comas3_1.topmods = FALSE_;
al__1.aerr = 0;
al__1.aunit = 16;
f_rew(&al__1);
for (il = 1; il <= 1000; ++il) {
i__3 = s_rsfe(&io___128);
if (i__3 != 0) {
goto L8;
}
i__3 = do_fio(&c__1, outq, (ftnlen)129);
if (i__3 != 0) {
goto L8;
}
i__3 = e_rsfe();
if (i__3 != 0) {
goto L8;
}
lenout = llen_(outq, &c__129, (ftnlen)129);
/* We inserted the '%' in subroutine littex, to guarantee including blank. */
s_wsfe(&io___129);
do_fio(&c__1, outq, lenout);
e_wsfe();
/* L7: */
}
L8:
cl__1.cerr = 0;
cl__1.cunit = 16;
cl__1.csta = 0;
f_clos(&cl__1);
}
goto L1;
L999:
cl__1.cerr = 0;
cl__1.cunit = 11;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = 12;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* askfig_ */
/* Subroutine */ int backfill_(integer *iunit, char *oldq, integer *lenold,
char *newq, integer *lennew, ftnlen oldq_len, ftnlen newq_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2[3];
alist al__1;
/* Builtin functions */
integer f_back(alist *), s_rsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_rsfe(void), i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
static integer linesback, ndx, line;
static char nowq[128], lineq[128*200];
/* Fortran I/O blocks */
static cilist io___131 = { 0, 0, 0, "(a)", 0 };
static cilist io___136 = { 0, 0, 0, "(a128)", 0 };
/* In iunit, looks backward for oldq, overwrites newq */
/* Safest if both are same length! */
linesback = 0;
L1:
al__1.aerr = 0;
al__1.aunit = *iunit;
f_back(&al__1);
io___131.ciunit = *iunit;
s_rsfe(&io___131);
do_fio(&c__1, nowq, (ftnlen)128);
e_rsfe();
ndx = i_indx(nowq, oldq, (ftnlen)128, (*lenold));
/* Save the line just read */
++linesback;
s_copy(lineq + (linesback - 1 << 7), nowq, (ftnlen)128, (ftnlen)128);
if (ndx == 0) {
al__1.aerr = 0;
al__1.aunit = *iunit;
f_back(&al__1);
goto L1;
}
/* If here, it's replacement time. */
i__1 = ndx + *lenold - 1;
/* Writing concatenation */
i__2[0] = ndx - 1, a__1[0] = nowq;
i__2[1] = *lennew, a__1[1] = newq;
i__2[2] = 128 - i__1, a__1[2] = nowq + i__1;
s_cat(lineq + (linesback - 1 << 7), a__1, i__2, &c__3, (ftnlen)128);
al__1.aerr = 0;
al__1.aunit = *iunit;
f_back(&al__1);
for (line = linesback; line >= 1; --line) {
io___136.ciunit = *iunit;
s_wsfe(&io___136);
do_fio(&c__1, lineq + (line - 1 << 7), (ftnlen)128);
e_wsfe();
/* L2: */
}
return 0;
} /* backfill_ */
/* Subroutine */ int beamend_(char *notexq, integer *lnote, ftnlen notexq_len)
{
/* System generated locals */
address a__1[4], a__2[3], a__3[2];
integer i__1, i__2[4], i__3[3], i__4[2];
char ch__1[1];
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static integer ip, mp, len, imp;
extern integer log2_(integer *);
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nole;
static char ulqq[1];
extern /* Subroutine */ int stop1_(void);
extern integer ncmid_(integer *, integer *);
static integer ndsav;
static char tempq[4], noteq[8];
extern /* Subroutine */ int notex_(char *, integer *, ftnlen), ntrbbb_(
integer *, char *, char *, integer *, char *, integer *, ftnlen,
ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *,
ftnlen);
static logical isdotm;
static integer lnoten, multip;
extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
;
/* Fortran I/O blocks */
static cilist io___143 = { 0, 6, 0, 0, 0 };
static cilist io___144 = { 0, 6, 0, 0, 0 };
ip = all_1.ipo[all_1.jn - 1];
multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8;
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 4) {
/* This is the LAST note in the xtup (i.e., all rests before). Make single. */
i__1 = 4 - multip;
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1);
notex_(notexq, lnote, (ftnlen)79);
strtmid_1.ixrest[commvl_1.ivx - 1] = 0;
return 0;
}
nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25];
/* Check for special situations with 2nds (see precrd) */
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) {
--nole;
} else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) {
++nole;
}
if (! comdraw_1.drawbm[commvl_1.ivx - 1]) {
/* Xtuplet with no beam, just put in the right kind of note */
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) {
/* Forced stem direction */
ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25];
i__1 = 4 - multip;
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1);
if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) {
all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2;
}
notex_(notexq, lnote, (ftnlen)79);
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav;
} else {
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
*lnote = lnoten + 3;
if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27))
{
/* Prior note is not regular-dotted */
if (multip == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "q";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
} else if (multip == -1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "h";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
} else if (multip == 1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "c";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
} else if (multip == 2) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 2, a__1[1] = "cc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
++(*lnote);
} else if (multip == 3) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 3, a__1[1] = "ccc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
*lnote += 2;
} else if (multip == -2) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 2, a__2[1] = "wh";
i__3[2] = 8, a__2[2] = noteq;
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
} else if (multip == -3) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 5, a__2[1] = "breve";
i__3[2] = 8, a__2[2] = noteq;
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
*lnote += 3;
} else {
s_wsle(&io___143);
e_wsle();
s_wsle(&io___144);
do_lio(&c__9, &c__1, "(Error in beamend, send source to "
"Dr. Don)", (ftnlen)42);
e_wsle();
stop1_();
}
} else {
/* Prior note is regular-dotted so this one is halved */
if (multip == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "c";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
} else if (multip == -1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "q";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
} else if (multip == -2) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "h";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
i__2[3] = 8, a__1[3] = noteq;
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
}
}
}
return 0;
}
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
*lnote = 0;
/* New way, with flipend, which was computed in beamstrt. */
if (strtmid_1.flipend[commvl_1.ivx - 1] && bit_test(all_1.ipl[
commvl_1.ivx + ip * 24 - 25],30)) {
i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25];
chax_(ch__1, (ftnlen)1, &i__1);
*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx
- 1] * 24 - 25] = *(unsigned char *)&ch__1[0];
}
if (ip > all_1.ibm1[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 -
25]) {
/* This is not a one-noter from beam-jump. Check if multiplicity has increased */
if (bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25],0)) {
/* Prior note is a rest, check one before that */
mp = (all_1.mult[commvl_1.ivx + (ip - 2) * 24 - 25] & 15) - 8;
} else {
mp = (all_1.mult[commvl_1.ivx + (ip - 1) * 24 - 25] & 15) - 8;
}
if (multip > mp) {
/* Assume 1-3, 2-3, or 1-2 */
i__1 = mp + 1;
for (imp = multip; imp >= i__1; --imp) {
ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq,
lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79);
/* L2: */
}
} else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27))
{
/* 2nd member of dotted xtup */
i__1 = multip + 1;
ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq,
lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79);
}
}
/* Beam termination and direction analysis */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23) && !
combjmp_1.isbjmp) {
/* This is the end of the first segment in a jump-beam. ivbj1=ivx will be number */
/* of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the */
/* voice of the 2nd part of jumped beam. (May need special treatment for */
/* multi-segment jump-beams */
combjmp_1.isbjmp = TRUE_;
combjmp_1.ivbj1 = commvl_1.ivx;
combjmp_1.ivbj2 = 0;
}
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) {
/* This is either a normal beamend or end of a sequence of jump-beam segments, */
/* so some sort of termination is required */
*(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25];
if (! combjmp_1.isbjmp || commvl_1.ivx != combjmp_1.ivbj2) {
/* Normal termination */
i__1 = commvl_1.ivx % 24;
ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
} else {
/* Terminate a sequence of jump-beam segments. */
i__1 = 225 - *(unsigned char *)ulqq;
chax_(ch__1, (ftnlen)1, &i__1);
*(unsigned char *)ulqq = *(unsigned char *)&ch__1[0];
i__1 = combjmp_1.ivbj1 % 24;
ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
}
}
/* And now the note */
if (*lnote > 0) {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = all_1.sq;
i__3[2] = 2, a__2[2] = "qb";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = all_1.sq;
i__4[1] = 2, a__3[1] = "qb";
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
}
*lnote += 3;
isdotm = FALSE_;
if (! comxtup_1.vxtup[commvl_1.ivx - 1]) {
i__1 = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 - 25]);
if (pow_ii(&c__2, &i__1) != all_1.nodur[commvl_1.ivx + ip * 24 - 25])
{
if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) {
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = 1, a__3[1] = "p";
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = 1, a__3[1] = "m";
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
isdotm = TRUE_;
}
++(*lnote);
}
}
/* 5/25/08 Allow >12 */
/* 5/9/10 Up to 24; replace 24 with 0 */
if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) {
/* call istring(mod(ivx,12),tempq,len) */
i__1 = commvl_1.ivx % 24;
istring_(&i__1, tempq, &len, (ftnlen)4);
} else {
/* call istring(mod(ivbj1,12),tempq,len) */
i__1 = combjmp_1.ivbj1 % 24;
istring_(&i__1, tempq, &len, (ftnlen)4);
}
if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2 && ! bit_test(
all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) {
combjmp_1.isbjmp = FALSE_;
}
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = len, a__3[1] = tempq;
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
*lnote += len;
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = lnoten, a__3[1] = noteq;
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
*lnote += lnoten;
if (isdotm) {
if (lnoten == 1) {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "{";
i__2[2] = 1, a__1[2] = noteq;
i__2[3] = 1, a__1[3] = "}";
s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79);
*lnote += 3;
} else {
i__1 = lnoten - 2;
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = lnoten - 1 - i__1, a__3[1] = noteq + i__1;
s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79);
++(*lnote);
}
}
return 0;
} /* beamend_ */
/* Subroutine */ int beamid_(char *notexq, integer *lnote, ftnlen notexq_len)
{
/* System generated locals */
address a__1[3], a__2[2], a__3[4];
integer i__1, i__2[3], i__3[2], i__4, i__5, i__6[4];
real r__1;
char ch__1[1];
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
extern integer igetbits_(integer *, integer *, integer *);
extern logical isdotted_(integer *, integer *, integer *);
static integer im, ip, len, ivb, iud, mua, mub, iup;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nole;
static char ulqq[1];
extern integer ncmid_(integer *, integer *);
static integer ipmid, iflop, ndsav;
static char noteq[8], tempq[4];
extern /* Subroutine */ int notex_(char *, integer *, ftnlen);
extern integer levrn_(integer *, integer *, integer *, integer *, integer
*);
static integer nlnum, multl, multr;
extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *,
char *, integer *, ftnlen, ftnlen, ftnlen);
static integer ipleft;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static real xnlmid;
static logical isdotm;
static integer lnoten, mprint, multip;
extern /* Subroutine */ int putxtn_(integer *, integer *, integer *,
integer *, real *, real *, integer *, integer *, real *, real *,
integer *, integer *, char *, integer *, integer *, real *,
integer *, integer *, logical *, ftnlen);
static integer ipright;
extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
;
*lnote = 0;
ip = all_1.ipo[all_1.jn - 1];
nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25];
/* Check for special situations with 2nds (see precrd) */
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) {
--nole;
} else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) {
++nole;
}
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8;
/* if (btest(islur(ivx,ip-1),3)) multip = multip+1 */
/* (Above test OK since must have ip>1). Double dotted note preceding */
/* Move the following, because can't ask for note until after checking for */
/* embedded xtup with number, due to ordering/octave feature. */
/* call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) */
}
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],28)) {
comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_;
}
if (comxtup_1.vxtup[commvl_1.ivx - 1]) {
/* In an xtup */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
/* Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK */
i__1 = 4 - ((all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8);
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1);
notex_(notexq, lnote, (ftnlen)79);
/* Re-zero so next note does not get confused */
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = 0;
return 0;
}
/* if (multip.le.0) then */
/* if (multip.le.0 .or. */
/* * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then */
if (! comdraw_1.drawbm[commvl_1.ivx - 1]) {
/* Xtuplet with no beam, just put in the right kind of note */
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) {
/* Forced stem direction */
ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25];
i__1 = 4 - multip;
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &
i__1);
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) ||
bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27))
{
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = all_1.nodur[
commvl_1.ivx + ip * 24 - 25] * 3 / 2;
} else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 -
25],27)) {
all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2;
}
notex_(notexq, lnote, (ftnlen)79);
all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav;
} else {
/* Use ulq for stem direction */
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
*lnote = 3;
if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],
27)) {
/* Prior note is not regular-dotted */
if (multip == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "q";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == -1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "h";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == 1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "c";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == 2) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 2, a__1[1] = "cc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
*lnote = 4;
} else if (multip == 3) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 3, a__1[1] = "ccc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
*lnote = 5;
} else if (multip == -2) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 2, a__2[1] = "wh";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
}
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27))
{
/* This note is regular dotted non-beamed xtup */
/* Writing concatenation */
i__3[0] = 3, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote = 4;
}
} else {
/* Prior note is regular-dotted so this one is halved */
if (multip == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "c";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == -1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "q";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == -2) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "h";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
}
}
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 8, a__2[1] = noteq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += lnoten;
}
return 0;
} else if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) {
/* In the beamed xtup but not the last note */
if (all_1.nodur[commvl_1.ivx + (ip - 1) * 24 - 25] > 0) {
/* Embedded Xtup, mult>0, starts here. Put in number if needed */
++comxtup_1.nxtinbm[commvl_1.ivx - 1];
iud = 1;
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25] == 'u') {
iud = -1;
}
/* Get ip#, notelevel of middle note (or gap) in xtup */
ipmid = ip + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25] / 2;
i__1 = ncmid_(&all_1.iv, &ipmid);
i__4 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8;
xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24
- 25], &all_1.irest[commvl_1.ivx + ipmid * 24 - 25], &
iud, &i__1, &i__4);
if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25] % 2 == 0) {
i__4 = ipmid - 1;
i__1 = ncmid_(&all_1.iv, &i__4);
i__5 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 -
25]) - 8;
xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + (
ipmid - 1) * 24 - 25], &all_1.irest[commvl_1.ivx
+ (ipmid - 1) * 24 - 25], &iud, &i__1, &i__5)) /
2;
}
iflop = 0;
if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ip), dabs(r__1)) <
3.f) {
iflop = -iud;
}
iup = iud + (iflop << 1);
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],14)) {
iup = -iup;
iflop = 0;
if (iud * iup < 0) {
iflop = iup;
}
}
/* Place number if needed */
if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],31)) {
mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 -
25], &c__5, &c__22);
if (mprint == 0) {
mprint = comxtup_1.mtupv[commvl_1.ivx +
comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25]
;
}
i__1 = ncmid_(&all_1.iv, &ip);
putxtn_(&mprint, &iflop, &multip, &iud, &comask_1.wheadpt,
&comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx
- 1], &comxtup_1.islope[commvl_1.ivx - 1], &
all_1.slfac, &xnlmid, &all_1.islur[commvl_1.ivx +
ip * 24 - 25], lnote, notexq, &i__1, &nlnum, &
comxtup_1.eloff[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25], &iup, &all_1.irest[
commvl_1.ivx + ip * 24 - 25], &c_false, (ftnlen)
79);
}
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
} else {
/* Intermediate note of xtup */
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
}
} else {
/* Last note of xtup (but not last note of beam!) */
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
}
} else if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
notex_(notexq, lnote, (ftnlen)79);
return 0;
} else {
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
}
/* Check if multiplicity changes in a way requiring action */
ipleft = ip - 1;
if (bit_test(all_1.irest[commvl_1.ivx + ipleft * 24 - 25],0)) {
--ipleft;
}
if (! bit_test(all_1.islur[commvl_1.ivx + ipleft * 24 - 25],20)) {
multl = (15 & all_1.mult[commvl_1.ivx + ipleft * 24 - 25]) - 8;
} else {
multl = 1;
}
mub = multip - multl;
ipright = ip + 1;
if (bit_test(all_1.irest[commvl_1.ivx + ipright * 24 - 25],0)) {
++ipright;
}
if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],20)) {
multr = (15 & all_1.mult[commvl_1.ivx + ipright * 24 - 25]) - 8;
} else {
multr = 1;
}
mua = multr - multip;
if (mub > 0 || mua < 0) {
/* Multiplicity has increased from left or will decrease to right. Need action. */
if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2) {
ivb = combjmp_1.ivbj1;
i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25];
chax_(ch__1, (ftnlen)1, &i__1);
*(unsigned char *)ulqq = *(unsigned char *)&ch__1[0];
} else {
ivb = commvl_1.ivx;
*(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[
commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25];
}
if (mua >= 0) {
ntrbbb_(&multip, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
} else if (multl >= multr) {
i__1 = multr + 1;
for (im = multip; im >= i__1; --im) {
ntrbbb_(&im, "t", ulqq, &ivb, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
/* L1: */
}
} else {
i__1 = multip;
for (im = multr + 1; im <= i__1; ++im) {
ntrbbb_(&im, "r", ulqq, &ivb, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
/* L2: */
}
ntrbbb_(&multr, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, (
ftnlen)1, (ftnlen)79);
}
} else if (ip > 1) {
/* Check for 2nd member of dotted xtup */
if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) {
i__1 = multip + 1;
ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq,
lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79);
}
}
/* Now put in the note */
if (*lnote > 0) {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = all_1.sq;
i__2[2] = 2, a__1[2] = "qb";
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 2, a__2[1] = "qb";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
}
*lnote += 3;
isdotm = FALSE_;
if (isdotted_(all_1.nodur, &commvl_1.ivx, &ip)) {
/* rule out ')' */
if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) {
if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],3)) {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
} else {
/* Double dot */
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 2, a__2[1] = "pp";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
} else {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "m";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
isdotm = TRUE_;
}
++(*lnote);
} else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) ||
bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) {
/* Special dotted notation for 2:1 xtup, or normal dot in xtup */
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
/* 5/25/08 Allow >12 */
if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) {
/* call istring(mod(ivx,12),tempq,len) */
i__1 = commvl_1.ivx % 24;
istring_(&i__1, tempq, &len, (ftnlen)4);
} else {
/* call istring(mod(ivbj1,12),tempq,len) */
i__1 = combjmp_1.ivbj1 % 24;
istring_(&i__1, tempq, &len, (ftnlen)4);
}
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = len, a__2[1] = tempq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += len;
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = lnoten, a__2[1] = noteq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += lnoten;
if (isdotm) {
if (lnoten == 2) {
/* Writing concatenation */
i__6[0] = *lnote, a__3[0] = notexq;
i__6[1] = 1, a__3[1] = "{";
i__6[2] = 1, a__3[2] = noteq + 1;
i__6[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__6, &c__4, (ftnlen)79);
*lnote += 3;
} else {
i__1 = lnoten - 2;
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
}
return 0;
} /* beamid_ */
/* Subroutine */ int beamn1_(char *notexq, integer *lnote, ftnlen notexq_len)
{
/* System generated locals */
address a__1[3], a__2[2], a__3[4];
integer i__1, i__2[3], i__3[2], i__4[4];
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static integer nd, im, ip1, len;
extern integer log2_(integer *);
static integer nole;
extern /* Subroutine */ int stop1_(void);
extern integer ncmid_(integer *, integer *);
static integer ndsav;
static char noteq[8];
extern /* Subroutine */ int notex_(char *, integer *, ftnlen);
static integer multr;
extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *,
char *, integer *, ftnlen, ftnlen, ftnlen), notefq_(char *,
integer *, integer *, integer *, ftnlen);
static logical isdotm;
static integer lnoten, multip;
extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
;
/* Fortran I/O blocks */
static cilist io___182 = { 0, 6, 0, 0, 0 };
static cilist io___183 = { 0, 6, 0, 0, 0 };
ip1 = all_1.ipo[all_1.jn - 1];
multip = (15 & all_1.mult[commvl_1.ivx + ip1 * 24 - 25]) - 8;
/* if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then */
if (! comdraw_1.drawbm[commvl_1.ivx - 1] && bit_test(all_1.irest[
commvl_1.ivx + ip1 * 24 - 25],0)) {
*lnote = 0;
/* The rest was already written in beamstrt, so just get out of here */
return 0;
}
nole = all_1.nolev[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25];
/* Check for special situations with 2nds (see precrd) */
if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25],
30)) {
--nole;
} else if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] *
24 - 25],31)) {
++nole;
}
if (comxtup_1.vxtup[commvl_1.ivx - 1] && ! comdraw_1.drawbm[commvl_1.ivx
- 1]) {
/* Xtuplet with no beam, just put in the right kind of note */
if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],30)) {
/* Forced stem direction */
ndsav = all_1.nodur[commvl_1.ivx + ip1 * 24 - 25];
i__1 = 4 - multip;
all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = pow_ii(&c__2, &i__1);
if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) ||
bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) {
all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = all_1.nodur[
commvl_1.ivx + ip1 * 24 - 25] * 3 / 2;
}
notex_(notexq, lnote, (ftnlen)79);
all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = ndsav;
} else {
i__1 = ncmid_(&all_1.iv, &ip1);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
*lnote = 3;
if (multip == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "q";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == -1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "h";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == 1) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 1, a__1[1] = "c";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else if (multip == 2) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 2, a__1[1] = "cc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
*lnote = 4;
} else if (multip == 3) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = all_1.sq;
i__2[1] = 3, a__1[1] = "ccc";
i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25);
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
*lnote = 5;
} else if (multip == -2) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 2, a__2[1] = "wh";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
} else if (multip == -3) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 5, a__2[1] = "breve";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote = 6;
} else {
s_wsle(&io___182);
e_wsle();
s_wsle(&io___183);
do_lio(&c__9, &c__1, "(Error in beamn1, send source to Dr. D"
"on)", (ftnlen)41);
e_wsle();
stop1_();
}
if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) ||
bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) {
/* Writing concatenation */
i__3[0] = 3, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote = 4;
}
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 8, a__2[1] = noteq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += lnoten;
}
return 0;
}
/* Check if mult. decreases from 1st note to 2nd */
if (all_1.ibm2[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25] >
ip1 || bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) {
/* More than one note or single-note before a multiplicity-down-up "][" */
if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) {
multr = 1;
} else if (! bit_test(all_1.irest[commvl_1.ivx + (ip1 + 1) * 24 - 25],
0)) {
multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 1) * 24 - 25]) - 8;
} else {
multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 2) * 24 - 25]) - 8;
}
*lnote = 0;
if (multr < multip) {
i__1 = multr + 1;
for (im = multip; im >= i__1; --im) {
ntrbbb_(&im, "r", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq,
lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79);
/* L1: */
}
}
}
/* Put in the note */
if (*lnote > 0) {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = all_1.sq;
i__2[2] = 2, a__1[2] = "qb";
s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = all_1.sq;
i__3[1] = 2, a__2[1] = "qb";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
}
*lnote += 3;
/* Check for dot */
isdotm = FALSE_;
if (! comxtup_1.vxtup[commvl_1.ivx - 1]) {
nd = all_1.nodur[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25];
if (nd != 0) {
i__1 = log2_(&nd);
if (pow_ii(&c__2, &i__1) != nd) {
if (! bit_test(all_1.iornq[commvl_1.ivx + ip1 * 24 - 1],13)) {
if (! bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],
3)) {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
} else {
/* Double dot */
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 2, a__2[1] = "pp";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
} else {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "m";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
isdotm = TRUE_;
}
++(*lnote);
}
}
} else if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) ||
bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) {
/* In an xtup with special 2:1 notation with a dot on 1st note, or normal dot */
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = "p";
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
/* Do the number; 0 if 12 */
/* 5/25/08 allow >12 */
if (! bit_test(all_1.irest[commvl_1.ivx + ip1 * 24 - 25],24)) {
/* call istring(mod(ivx,12),noteq,len) */
i__1 = commvl_1.ivx % 24;
istring_(&i__1, noteq, &len, (ftnlen)8);
} else {
/* call istring(mod(ivbj1,12),noteq,len) */
i__1 = combjmp_1.ivbj1 % 24;
istring_(&i__1, noteq, &len, (ftnlen)8);
}
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = len, a__2[1] = noteq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += len;
i__1 = ncmid_(&all_1.iv, &ip1);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = lnoten, a__2[1] = noteq;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
*lnote += lnoten;
if (isdotm) {
if (lnoten == 1) {
/* Writing concatenation */
i__4[0] = *lnote, a__3[0] = notexq;
i__4[1] = 1, a__3[1] = "{";
i__4[2] = 1, a__3[2] = noteq;
i__4[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
*lnote += 3;
} else {
i__1 = lnoten - 2;
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1;
s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79);
++(*lnote);
}
}
return 0;
} /* beamn1_ */
/* Subroutine */ int beamstrt_(char *notexq, integer *lnote, integer *nornb,
integer *ihornb, real *space, real *squez, integer *ib, ftnlen
notexq_len)
{
/* System generated locals */
address a__1[3], a__2[2], a__3[5];
integer i__1, i__2, i__3, i__4[3], i__5[2], i__6[5];
real r__1;
char ch__1[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer i_nint(real *), s_wsfi(icilist *), do_fio(integer *, char *,
ftnlen), e_wsfi(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer pow_ii(integer *, integer *), i_sign(integer *, integer *),
lbit_shift(integer, integer);
/* Local variables */
static logical addbrack;
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
extern integer igetbits_(integer *, integer *, integer *);
static logical usexnumt;
static integer nomornlev, ip, levbracket, ibc, inb, iud, imp, ivf, ipp,
iup;
static logical xto;
static integer ipb1, iadj, icrd;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern doublereal feon_(real *);
static integer levc, nole, iorn;
static real ymin, ybot;
static integer levx;
static real xnsk;
extern integer ncmid_(integer *, integer *);
static real ybeam;
static integer ipmid, iflop;
static real bmlev;
static integer icrdx, multb, ltemp;
static char noteq[8], tempq[79];
extern integer levrn_(integer *, integer *, integer *, integer *, integer
*);
static char restq[40];
static integer nlnum, lrest;
extern /* Subroutine */ int notex_(char *, integer *, ftnlen);
static integer isssb;
static real zmult;
extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *,
char *, integer *, ftnlen, ftnlen, ftnlen);
static real xnlmid;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten;
extern /* Subroutine */ int setupb_(real *, integer *, real *, real *,
integer *, real *, integer *);
static integer mprint;
static real xslope;
extern /* Subroutine */ int putxtn_(integer *, integer *, integer *,
integer *, real *, real *, integer *, integer *, real *, real *,
integer *, integer *, char *, integer *, integer *, real *,
integer *, integer *, logical *, ftnlen);
static integer maxdrop;
/* Fortran I/O blocks */
static icilist io___212 = { 0, tempq, 0, "(i2)", 2, 1 };
/* The following is just to save the outputs from SetupB for the case of */
/* xtups starting with a rest, where beamstrt is called twice. */
/* Parameter adjustments */
--squez;
--space;
ihornb -= 25;
--nornb;
/* Function Body */
ibc = all_1.ibmcnt[commvl_1.ivx - 1];
ipb1 = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25];
multb = (15 & all_1.mult[commvl_1.ivx + ipb1 * 24 - 25]) - 8;
ip = all_1.ipo[all_1.jn - 1];
/* Compute slopes and note offsets from start of beam. Inside SetupB, for each */
/* xtup in the beam, set eloff,mtupv (in comxtup) for printed number. */
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0 && ! bit_test(all_1.nacc[
commvl_1.ivx + ip * 24 - 25],21)) {
setupb_(comxtup_1.xelsk, &comipb_1.nnb, &comipb_1.sumx, &
comipb_1.sumy, comipb_1.ipb, &comipb_1.smed, &
strtmid_1.ixrest[commvl_1.ivx - 1]);
}
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],21)) {
/* This is start of later segment of single-slope beam group so use slope and */
/* height from prior beam. Slope is already OK. */
++comxtup_1.issb[commvl_1.ivx - 1];
comxtup_1.nolev1[commvl_1.ivx - 1] = comxtup_1.lev1ssb[commvl_1.ivx +
comxtup_1.issb[commvl_1.ivx - 1] * 24 - 25];
}
*lnote = 0;
comdraw_1.drawbm[commvl_1.ivx - 1] = TRUE_;
if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],28) &&
strtmid_1.ixrest[commvl_1.ivx - 1] != 2) {
comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_;
++comxtup_1.nxtinbm[commvl_1.ivx - 1];
/* irest(28)=>Xtup starts on this note. Set up for xtuplet. */
/* Number goes on notehead side at middle note (or gap) of xtup, unless that */
/* puts it in staff, then it flops to stem (or beam) side. */
/* __ __ */
/* | | | O | | */
/* O | | O */
/* |___| O |__| | */
/* iud -1 -1 1 1 ...stem direction */
/* iflop 0 1 -1 0 ...direction of flop */
/* iup -1 1 -1 1 ...direction of number and bracket */
iud = 1;
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u')
{
iud = -1;
}
/* Get ip#, note level of middle note (or gap) in xtup */
ipmid = ipb1 + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25] / 2;
/* 130129 If middle note is a rest, go to next note. Note last note cannot */
/* be a rest */
L14:
if (bit_test(all_1.irest[commvl_1.ivx + ipmid * 24 - 25],0)) {
++ipmid;
goto L14;
}
i__1 = ncmid_(&all_1.iv, &ipmid);
i__2 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8;
xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24 - 25], &
all_1.irest[commvl_1.ivx + ipmid * 24 - 25], &iud, &i__1, &
i__2);
if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[commvl_1.ivx - 1]
* 24 - 25] % 2 == 0) {
i__2 = ipmid - 1;
i__1 = ncmid_(&all_1.iv, &i__2);
i__3 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 - 25]) -
8;
xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + (ipmid - 1)
* 24 - 25], &all_1.irest[commvl_1.ivx + (ipmid - 1) * 24
- 25], &iud, &i__1, &i__3)) / 2;
}
iflop = 0;
if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ipb1), dabs(r__1)) < 3.f) {
iflop = -iud;
}
iup = iud + (iflop << 1);
if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],14)) {
/* Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) */
iup = -iup;
iflop = 0;
if (iud * iup < 0) {
iflop = iup;
}
}
/* Determine if a beam is to be drawn */
i__1 = all_1.ibm2[commvl_1.ivx + ibc * 24 - 25];
for (ipp = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; ipp <= i__1;
++ipp) {
if ((15 & all_1.mult[commvl_1.ivx + ipp * 24 - 25]) - 8 <= 0) {
comdraw_1.drawbm[commvl_1.ivx - 1] = FALSE_;
goto L6;
}
/* L5: */
}
comdraw_1.drawbm[commvl_1.ivx - 1] = ! bit_test(all_1.islur[
commvl_1.ivx + all_1.ibm1[commvl_1.ivx + ibc * 24 - 25] * 24
- 25],18);
L6:
/* Are we using tuplet.tex? */
usexnumt = comnvst_1.cstuplet && ! comdraw_1.drawbm[commvl_1.ivx - 1];
/* Place xtup number if needed */
if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31) ||
multb <= 0) {
mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - 25], &
c__5, &c__22);
if (mprint == 0) {
mprint = comxtup_1.mtupv[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25];
}
i__1 = ncmid_(&all_1.iv, &ipb1);
putxtn_(&mprint, &iflop, &multb, &iud, &comask_1.wheadpt, &
comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx - 1], &
comxtup_1.islope[commvl_1.ivx - 1], &all_1.slfac, &xnlmid,
&all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], lnote,
notexq, &i__1, &nlnum, &comxtup_1.eloff[commvl_1.ivx +
comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25], &iup, &
all_1.irest[commvl_1.ivx + ipb1 * 24 - 25], &usexnumt, (
ftnlen)79);
}
if (! comdraw_1.drawbm[commvl_1.ivx - 1]) {
/* Xtuplet with no beam */
if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31)) {
/* Number printing has not been suppressed, so put in the bracket. */
/* scale = stretch factor for bracket if there are asx's */
/* xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) */
r__1 = space[*ib] / squez[*ib];
xnsk = (comeskz2_1.eskz2[commvl_1.ivx + (ipb1 +
comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[
commvl_1.ivx - 1] * 24 - 25] - 1) * 24 - 25] -
comeskz2_1.eskz2[commvl_1.ivx + ipb1 * 24 - 25]) /
squez[*ib] / feon_(&r__1);
if (iup == 1) {
if (*lnote > 0) {
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = 1, a__1[1] = all_1.sq;
i__4[2] = 5, a__1[2] = "ovbkt";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 5, a__2[1] = "ovbkt";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
}
} else {
if (*lnote > 0) {
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = 1, a__1[1] = all_1.sq;
i__4[2] = 5, a__1[2] = "unbkt";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
} else {
/* Introduced 12/5/98, req'd due to possible presence of in-line TeX */
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 5, a__2[1] = "unbkt";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
}
}
*lnote += 6;
if (all_1.iline == 1) {
comipb_1.smed /= 1.f - comtop_1.fracindent;
}
xslope = comipb_1.smed * 1.8f * all_1.slfac;
comxtup_1.islope[commvl_1.ivx - 1] = i_nint(&xslope);
r__1 = comipb_1.smed * comxtup_1.eloff[commvl_1.ivx - 1];
comxtup_1.nolev1[commvl_1.ivx - 1] = nlnum - i_nint(&r__1);
if (comxtup_1.islope[commvl_1.ivx - 1] == 0) {
--comxtup_1.nolev1[commvl_1.ivx - 1];
}
if (iup == 1) {
comxtup_1.nolev1[commvl_1.ivx - 1] += 4;
}
levbracket = comxtup_1.nolev1[commvl_1.ivx - 1];
if (iup == 1 && comnvst_1.cstuplet) {
--levbracket;
}
i__1 = ncmid_(&all_1.iv, &ipb1);
notefq_(noteq, &lnoten, &levbracket, &i__1, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = lnoten, a__1[1] = noteq;
i__4[2] = 1, a__1[2] = "{";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
*lnote = *lnote + lnoten + 1;
if (xnsk < .995f) {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i1,f3.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real));
e_wsfi();
*lnote += 4;
} else if (xnsk < 9.995f) {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f4.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real));
e_wsfi();
*lnote += 4;
} else {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 5 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f5.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real));
e_wsfi();
*lnote += 5;
}
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
++(*lnote);
if (bit_test(all_1.mult[commvl_1.ivx + ipb1 * 24 - 25],4)) {
/* Tweak slope of bracket */
comxtup_1.islope[commvl_1.ivx - 1] = comxtup_1.islope[
commvl_1.ivx - 1] + igetbits_(&all_1.mult[
commvl_1.ivx + ipb1 * 24 - 25], &c__5, &c__5) -
16;
}
if (comxtup_1.islope[commvl_1.ivx - 1] < 0 ||
comxtup_1.islope[commvl_1.ivx - 1] >= 10) {
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = 1, a__2[1] = "{";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
++(*lnote);
if (comxtup_1.islope[commvl_1.ivx - 1] < -9) {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i3)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx
- 1], (ftnlen)sizeof(integer));
e_wsfi();
*lnote += 3;
} else {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 2 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx
- 1], (ftnlen)sizeof(integer));
e_wsfi();
*lnote += 2;
}
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
++(*lnote);
} else {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 1 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1],
(ftnlen)sizeof(integer));
e_wsfi();
++(*lnote);
}
/* Done with bracket */
}
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) {
/* Put in the rest. Possible problem: Rest is a spacing char, but between */
/* beamstrt and beamn1 some non-spacing chars. are inserted. */
/* 130126 Deal with vertical shifts of rest starting xtuplet */
/* if (multb .eq. 0) then */
/* notexq = notexq(1:lnote)//sq//'qp' */
/* lnote = lnote+3 */
/* else if (.not.drawbm(ivx).and.multb.eq.1) then */
/* notexq = notexq(1:lnote)//sq//'ds' */
/* lnote = lnote+3 */
/* else if (.not.drawbm(ivx).and.multb.eq.2) then */
/* notexq = notexq(1:lnote)//sq//'qs' */
/* lnote = lnote+3 */
/* else if (.not.drawbm(ivx).and.multb.eq.3) then */
/* notexq = notexq(1:lnote)//sq//'hs' */
/* lnote = lnote+3 */
/* else */
/* notexq = notexq(1:lnote)//sq//'hpause' */
/* lnote = lnote+7 */
/* end if */
lrest = 3;
if (multb == 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 2, a__2[1] = "qp";
s_cat(restq, a__2, i__5, &c__2, (ftnlen)40);
} else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 1)
{
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 2, a__2[1] = "ds";
s_cat(restq, a__2, i__5, &c__2, (ftnlen)40);
} else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 2)
{
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 2, a__2[1] = "qs";
s_cat(restq, a__2, i__5, &c__2, (ftnlen)40);
} else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 3)
{
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 2, a__2[1] = "hs";
s_cat(restq, a__2, i__5, &c__2, (ftnlen)40);
} else {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 6, a__2[1] = "hpause";
s_cat(restq, a__2, i__5, &c__2, (ftnlen)40);
lrest = 7;
}
nole = (all_1.nolev[commvl_1.ivx + ip * 24 - 25] + 20) % 100
- 20;
if (nole == 0) {
/* Rest is not raised */
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = 40, a__2[1] = restq;
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
*lnote += lrest;
} else {
if (abs(nole) < 10) {
i__1 = abs(nole) + 48;
chax_(ch__1, (ftnlen)1, &i__1);
s_copy(tempq, ch__1, (ftnlen)79, (ftnlen)1);
ltemp = 1;
} else {
s_wsfi(&io___212);
i__1 = abs(nole);
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfi();
ltemp = 2;
}
if (nole > 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = all_1.sq;
i__6[1] = 5, a__3[1] = "raise";
i__6[2] = ltemp, a__3[2] = tempq;
i__6[3] = 1, a__3[3] = all_1.sq;
i__6[4] = 9, a__3[4] = "internote";
s_cat(tempq, a__3, i__6, &c__5, (ftnlen)79);
} else {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = all_1.sq;
i__6[1] = 5, a__3[1] = "lower";
i__6[2] = ltemp, a__3[2] = tempq;
i__6[3] = 1, a__3[3] = all_1.sq;
i__6[4] = 9, a__3[4] = "internote";
s_cat(tempq, a__3, i__6, &c__5, (ftnlen)79);
}
ltemp += 16;
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = ltemp, a__1[1] = tempq;
i__4[2] = lrest, a__1[2] = restq;
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
*lnote = *lnote + ltemp + lrest;
}
/* No need to come back through this subroutine (as would if rest starts bar */
/* & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. */
strtmid_1.ixrest[commvl_1.ivx - 1] = 0;
}
return 0;
}
/* End if block for non-beamed xtup start...note we returned */
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) {
/* Insert rest at start of beamed xtup. See above note for possible problem. */
i__1 = 4 - multb;
all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = pow_ii(&c__2, &i__1);
notex_(tempq, <emp, (ftnlen)79);
if (*lnote > 0) {
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = ltemp, a__2[1] = tempq;
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
} else {
s_copy(notexq, tempq, (ftnlen)79, ltemp);
}
*lnote += ltemp;
/* Re-zero just in case! */
all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = 0;
++all_1.ibm1[commvl_1.ivx + ibc * 24 - 25];
/* See if next note is a non-rest */
if (! bit_test(all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],0)
) {
strtmid_1.ixrest[commvl_1.ivx - 1] = 2;
} else {
/* Suppress reprinting xtup number next time through beamstrt */
all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set(
all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25],31);
/* Set new xtup start flag */
all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set(
all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],28);
}
return 0;
}
}
/* Just ended if block for xtups */
if (comxtup_1.vxtup[commvl_1.ivx - 1] && ipb1 == all_1.ibm2[commvl_1.ivx
+ ibc * 24 - 25]) {
/* Move actual note writing to beamend */
strtmid_1.ixrest[commvl_1.ivx - 1] = 4;
return 0;
}
if (comxtup_1.issb[commvl_1.ivx - 1] == 0) {
/* 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed */
iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, &
c__11) - 30;
if (iadj != -30) {
comxtup_1.nolev1[commvl_1.ivx - 1] += iadj;
i__1 = comxtup_1.nssb[commvl_1.ivx - 1];
for (isssb = 1; isssb <= i__1; ++isssb) {
comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] += iadj;
/* L2: */
}
}
iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, &
c__17) - 30;
if (iadj != -30) {
comxtup_1.islope[commvl_1.ivx - 1] += iadj;
if ((i__1 = comxtup_1.islope[commvl_1.ivx - 1], abs(i__1)) > 9) {
comxtup_1.islope[commvl_1.ivx - 1] = i_sign(&c__9, &
comxtup_1.islope[commvl_1.ivx - 1]);
}
if (comxtup_1.nssb[commvl_1.ivx - 1] > 0) {
/* Cycle thru non-rest notes in SSBG, looking for bmstrts. */
isssb = 0;
i__1 = comipb_1.nnb;
for (inb = 2; inb <= i__1; ++inb) {
if (bit_test(all_1.nacc[commvl_1.ivx + comipb_1.ipb[inb -
1] * 24 - 25],21)) {
/* Beam segment start. New start level */
++isssb;
comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] +=
comxtup_1.islope[commvl_1.ivx - 1] *
comxtup_1.xelsk[inb - 1] / all_1.slfac;
}
/* L4: */
}
}
}
}
iadj = igetbits_(&all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], &c__2, &
c__27);
addbrack = FALSE_;
if (bit_test(all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25],30)) {
/* Check for altered starting polarity. Only in forced beams. Nominal start */
/* level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). */
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u'
&& comxtup_1.nolev1[commvl_1.ivx - 1] + 6 < all_1.nolev[
commvl_1.ivx + ipb1 * 24 - 25]) {
if (*lnote == 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 5, a__2[1] = "loff{";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = 1, a__1[1] = all_1.sq;
i__4[2] = 5, a__1[2] = "loff{";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
}
*lnote += 6;
addbrack = TRUE_;
} else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25]
== 'l' && comxtup_1.nolev1[commvl_1.ivx - 1] - 6 >
all_1.nolev[commvl_1.ivx + ipb1 * 24 - 25]) {
if (*lnote == 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = all_1.sq;
i__5[1] = 5, a__2[1] = "roff{";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = 1, a__1[1] = all_1.sq;
i__4[2] = 5, a__1[2] = "roff{";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
}
*lnote += 6;
addbrack = TRUE_;
}
/* Check end level for possible flipping in forced beam. Have to do it */
/* here since with multiple voices, xelsk will not be preserved. */
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25] == 'u') {
bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] + 6 + comxtup_1.islope[
commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] /
all_1.slfac;
strtmid_1.flipend[commvl_1.ivx - 1] = bmlev < (real) all_1.nolev[
commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] *
24 - 25];
} else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25] == 'l') {
bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] - 6 + comxtup_1.islope[
commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] /
all_1.slfac;
strtmid_1.flipend[commvl_1.ivx - 1] = bmlev > (real) all_1.nolev[
commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] *
24 - 25];
}
}
i__1 = multb + iadj;
ntrbbb_(&i__1, "i", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), &
commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79);
/* Put in name of start level and slope, after correcting nolev1 if xtup */
/* started with a rest. */
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) {
r__1 = comxtup_1.nolev1[commvl_1.ivx - 1] + comxtup_1.xelsk[0] *
comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac;
comxtup_1.nolev1[commvl_1.ivx - 1] = i_nint(&r__1);
}
i__1 = ncmid_(&all_1.iv, &ipb1);
notefq_(noteq, &lnoten, &comxtup_1.nolev1[commvl_1.ivx - 1], &i__1, (
ftnlen)8);
if (comxtup_1.islope[commvl_1.ivx - 1] < 0) {
/* Writing concatenation */
i__4[0] = *lnote, a__1[0] = notexq;
i__4[1] = lnoten, a__1[1] = noteq;
i__4[2] = 1, a__1[2] = "{";
s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79);
*lnote = *lnote + 4 + lnoten;
i__1 = *lnote - 3;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen)
sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
} else {
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = lnoten, a__2[1] = noteq;
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
*lnote = *lnote + 1 + lnoten;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = notexq + (*lnote - 1);
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen)
sizeof(integer));
e_wsfi();
}
/* Check for beam-thk fine-tuning */
if (iadj > 0) {
i__1 = multb + 1;
for (imp = multb + iadj; imp >= i__1; --imp) {
ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), &
commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, (
ftnlen)79);
/* L1: */
}
}
/* If we shifted, must close with right bracket */
if (addbrack) {
/* Writing concatenation */
i__5[0] = *lnote, a__2[0] = notexq;
i__5[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79);
++(*lnote);
}
/* Get 'floor' zmin for figures */
/* Note: Will not come thru here on 1st note of unbeamed xtup, so figure height */
/* won't be adjusted. If anyone ever needs that, need to duplicate this */
/* functionality up above, before exiting. */
if (all_1.figbass && (commvl_1.ivx == 1 || commvl_1.ivx ==
comfig_1.ivxfig2)) {
if (commvl_1.ivx == 1) {
ivf = 1;
} else {
ivf = comfig_1.ivxfig2;
}
zmult = (multb - 1) * 1.2f;
ymin = 100.f;
i__1 = comipb_1.nnb;
for (inb = 1; inb <= i__1; ++inb) {
if (all_1.isfig[ivf + (comipb_1.ipb[inb - 1] << 1) - 3]) {
if (*(unsigned char *)&all_1.ulq[all_1.iv + ibc * 24 - 25] ==
'u') {
ybot = (real) all_1.nolev[all_1.iv + comipb_1.ipb[inb - 1]
* 24 - 25];
} else {
ybot = comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac *
comxtup_1.xelsk[inb - 1] + comxtup_1.nolev1[
commvl_1.ivx - 1] - all_1.stemlen - zmult;
}
ymin = dmin(ymin,ybot);
}
/* L3: */
}
maxdrop = ncmid_(&all_1.iv, &ipb1) - 4 - ymin + 5.01f;
/* Computing MAX */
i__1 = all_1.ifigdr[ivf + (all_1.iline << 1) - 3];
all_1.ifigdr[ivf + (all_1.iline << 1) - 3] = max(i__1,maxdrop);
}
/* Compute ornament levels if needed */
nomornlev = ncmid_(&all_1.iv, &ipb1) + 5;
iorn = 0;
i__1 = comipb_1.nnb;
for (inb = 1; inb <= i__1; ++inb) {
ip = comipb_1.ipb[inb - 1];
if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],23)) {
goto L8;
}
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],26) && *(
unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] ==
'l') {
/* letter-dynamic or hairpin ending under down-beamed */
++iorn;
ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] - all_1.stemlen +
comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[inb
- 1] / all_1.slfac + 1 - (multb - 1) * 1.2f;
/* Computing MIN */
r__1 = ybeam - 3.f;
i__2 = i_nint(&r__1), i__3 = nomornlev - 10;
ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3);
} else if (! bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F */
/* 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD */
/* Non-chord. There IS an ornament. Need ihornb only if upbeam, and if */
/* ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) */
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] ==
'u' && (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] *
24 - 1] & 4163566) > 0) {
++iorn;
all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set(all_1.iornq[
commvl_1.ivx + ip * 24 - 1],22);
ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] + all_1.stemlen +
comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[
inb - 1] / all_1.slfac - 1 + (multb - 1) * 1.2f;
/* Computing MAX */
r__1 = ybeam + 3.f;
i__2 = i_nint(&r__1);
ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev);
}
} else {
/* In a chord. Orn may be on main note or non-main or both. Set ihornb if */
/* upbeam and highest note has orn, or down beam and lowest. Find 1st chord note */
i__2 = comtrill_1.ncrd;
for (comtrill_1.icrd1 = 1; comtrill_1.icrd1 <= i__2;
++comtrill_1.icrd1) {
if ((255 & comtrill_1.icrdat[comtrill_1.icrd1 - 1]) == ip && (
15 & lbit_shift(comtrill_1.icrdat[comtrill_1.icrd1 -
1], (ftnlen)-8)) == commvl_1.ivx) {
goto L11;
}
/* L10: */
}
L11:
/* Find outermost note, min or max depending on beam direction ulq. xto is true */
/* if there's an ornament on that note. Expand orn list to include ._, since if */
/* on extreme chord note in beam, will move. */
/* So ornaments are all except 0,4,13 (,g,) */
levx = all_1.nolev[commvl_1.ivx + ip * 24 - 25];
xto = (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] * 24 - 1]
& 4186094) > 0;
icrdx = 0;
i__2 = comtrill_1.ncrd;
for (icrd = comtrill_1.icrd1; icrd <= i__2; ++icrd) {
if ((255 & comtrill_1.icrdat[icrd - 1]) != ip || (15 &
lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen)-8))
!= commvl_1.ivx) {
goto L13;
}
levc = 127 & lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen)
-12);
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25]
== 'u' && levc > levx || *(unsigned char *)&
all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'l' &&
levc < levx) {
levx = levc;
icrdx = icrd;
xto = (comtrill_1.icrdorn[icrd - 1] & 4186094) > 0;
}
/* L12: */
}
L13:
/* If there's orn on extreme note, do stuff */
if (xto) {
++iorn;
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25]
== 'u') {
ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] +
all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1]
* comxtup_1.xelsk[inb - 1] / all_1.slfac - 1 + (
multb - 1) * 1.2f;
/* Computing MAX */
r__1 = ybeam + 3.f;
i__2 = i_nint(&r__1);
ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev);
} else {
ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] -
all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1]
* comxtup_1.xelsk[inb - 1] / all_1.slfac + 1 - (
multb - 1) * 1.2f;
/* Computing MIN */
r__1 = ybeam - 3.f;
i__2 = i_nint(&r__1), i__3 = nomornlev - 10;
ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3);
}
if (icrdx == 0) {
/* Affected ornament is on main note */
all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set(
all_1.iornq[commvl_1.ivx + ip * 24 - 1],22);
} else {
comtrill_1.icrdorn[icrdx - 1] = bit_set(
comtrill_1.icrdorn[icrdx - 1],22);
}
}
}
L8:
;
}
/* Henceforth nornb will be a counter. */
if (iorn > 0) {
nornb[commvl_1.ivx] = 1;
}
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) {
strtmid_1.ixrest[commvl_1.ivx - 1] = 0;
}
return 0;
} /* beamstrt_ */
/* meter space (pts) = xb4mbr = musicsize*facmtr */
/* From other */
/* * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, */
/* Subroutine */ int catspace_(real *space, real *squez, integer *nnsk)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer iptr;
i__1 = c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1;
for (iptr = c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1]; iptr <= i__1;
++iptr) {
if ((r__1 = *space - c1omnotes_1.durb[iptr - 1], dabs(r__1)) <
comtol_1.tol) {
if ((r__1 = *squez - c1omnotes_1.sqzb[iptr - 1], dabs(r__1)) <
comtol_1.tol) {
/* Increment pre-existing entry */
c1omnotes_1.nnpd[iptr - 1] += *nnsk;
return 0;
}
}
/* L16: */
}
/* Didn't find current duration & squez, so add a new entry. */
/* No particular reason to keep in order, so add at the end. */
c1omnotes_1.nnpd[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *nnsk;
c1omnotes_1.durb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *space;
c1omnotes_1.sqzb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *squez;
++c1omnotes_1.nptr[c1omnotes_1.ibarcnt];
return 0;
} /* catspace_ */
/* Character */ VOID chax_(char *ret_val, ftnlen ret_val_len, integer *n)
{
/* The only reason for this seemingly do-nothing function is to get around an */
/* apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! */
*(unsigned char *)ret_val = (char) (*n);
return ;
} /* chax_ */
/* Subroutine */ int checkdyn_(char *lineq, integer *iccount, integer *ibar,
ftnlen lineq_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2[3], i__3;
real r__1;
char ch__1[4], ch__2[1];
icilist ici__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
, i_nint(real *);
/* Local variables */
static integer ipm, iend;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer idno;
static real fnum;
static char durq[1];
extern /* Subroutine */ int stop1_(void), errmsg_(char *, integer *,
integer *, char *, ftnlen, ftnlen);
static logical txtdyn;
extern /* Subroutine */ int readnum_(char *, integer *, char *, real *,
ftnlen, ftnlen);
static char dynsymq[4];
txtdyn = FALSE_;
/* On entry, iccount is on "D" */
i__1 = *iccount;
if (s_cmp(lineq + i__1, "\"", *iccount + 1 - i__1, (ftnlen)1) == 0) {
/* Dynamic text */
i__1 = *iccount + 1;
iend = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1);
if (iend == 0) {
i__1 = *iccount + 1;
errmsg_(lineq, &i__1, ibar, "Dynamic text must be terminated wit"
"h double quote!", (ftnlen)128, (ftnlen)50);
stop1_();
}
/* Set iccount to character after 2nd ", and set ipm */
*iccount = *iccount + iend + 2;
ipm = i_indx("- +", lineq + (*iccount - 1), (ftnlen)3, (ftnlen)1);
if (ipm == 0) {
errmsg_(lineq, iccount, ibar, "Expected \"-\", \"+\", or blank h"
"ere!", (ftnlen)128, (ftnlen)33);
stop1_();
}
} else {
/* Expect ordinary dynamic */
for (iend = *iccount + 2; iend <= 128; ++iend) {
ipm = i_indx("- +", lineq + (iend - 1), (ftnlen)3, (ftnlen)1);
if (ipm > 0) {
goto L2;
}
/* L1: */
}
L2:
if (iend - *iccount > 5 || iend - *iccount < 2) {
i__1 = iend - 1;
errmsg_(lineq, &i__1, ibar, "Wrong length for dynamic mark!", (
ftnlen)128, (ftnlen)30);
stop1_();
}
i__1 = *iccount;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = iend - 1 - i__1;
ici__1.iciunit = lineq + i__1;
/* Writing concatenation */
i__2[0] = 2, a__1[0] = "(a";
i__3 = iend + 47 - *iccount;
chax_(ch__2, (ftnlen)1, &i__3);
i__2[1] = 1, a__1[1] = ch__2;
i__2[2] = 1, a__1[2] = ")";
ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1);
s_rsfi(&ici__1);
do_fio(&c__1, dynsymq, (ftnlen)4);
e_rsfi();
idno = (i_indx("ppppppp pp p mp mf f fp sfz ff fff ffff< "
"> ", dynsymq, (ftnlen)56, (ftnlen)4) + 3) / 4;
if (idno == 0) {
i__1 = *iccount + 1;
errmsg_(lineq, &i__1, ibar, "Illegal dynamic mark!", (ftnlen)128,
(ftnlen)21);
stop1_();
}
*iccount = iend;
}
if (ipm != 2) {
/* There is a vertical shift, have "+" or "-" */
++(*iccount);
if (i_indx("0123456789", lineq + (*iccount - 1), (ftnlen)10, (ftnlen)
1) == 0) {
errmsg_(lineq, iccount, ibar, "Expected integer here for vertica"
"l offset!", (ftnlen)128, (ftnlen)42);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
idno = i_nint(&fnum);
if (idno > 63) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Vertical offset for dynamic mark mu"
"st be (-63,63)!", (ftnlen)128, (ftnlen)50);
stop1_();
}
ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1);
if (ipm == 0) {
errmsg_(lineq, iccount, ibar, "Expected \"+\", \"-\", or blank h"
"ere!", (ftnlen)128, (ftnlen)33);
stop1_();
}
if (ipm != 2) {
/* There is a horizontal shift */
++(*iccount);
if (i_indx(".0123456789", lineq + (*iccount - 1), (ftnlen)11, (
ftnlen)1) == 0) {
errmsg_(lineq, iccount, ibar, "Expected number here for hori"
"zontal offset!", (ftnlen)128, (ftnlen)43);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
r__1 = fnum * 10;
idno = i_nint(&r__1);
if (idno > 255) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Horizontal offset for dynamic m"
"ark must be (-25.5,25.5)!", (ftnlen)128, (ftnlen)56);
stop1_();
} else if (*(unsigned char *)durq != ' ') {
errmsg_(lineq, iccount, ibar, "There should be a blank here!",
(ftnlen)128, (ftnlen)29);
stop1_();
}
}
/* iccount should be on the blank at the end of the entire symbol */
}
return 0;
} /* checkdyn_ */
/* Subroutine */ int chkarp_(integer *ncrd, integer *icrdat, integer *ivx,
integer *ip, logical *iscacc, logical *isarp)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer lbit_shift(integer, integer);
/* Local variables */
static integer icrd;
static logical found1;
/* subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, */
/* * icashft) */
/* Parameter adjustments */
--icrdat;
/* Function Body */
found1 = FALSE_;
/* icashft will be max left shift of accid's in chord notes. */
/* Used only for spacing checks. */
/* Will include left shift of chord note itself. */
/* Rezero after use. */
i__1 = *ncrd;
for (icrd = 1; icrd <= i__1; ++icrd) {
/* This if block cycles thru all chord notes on ivx,ip; then returns. */
if ((255 & icrdat[icrd]) == *ip && (15 & lbit_shift(icrdat[icrd], (
ftnlen)-8)) == *ivx) {
found1 = TRUE_;
*iscacc = *iscacc || bit_test(icrdat[icrd],19) && ! bit_test(
icrdat[icrd],27);
/* Accid on this chord note, and it's not midi-only. */
/* irshft = igetbits(icrdot(icrd),7,20) */
/* c */
/* c Include increment for notehead shift */
/* c */
/* if (btest(icrdat(icrd),23)) then */
/* if (irshft .eq. 0) then */
/* irshft = 44 */
/* else */
/* irshft=irshft-20 */
/* end if */
/* end if */
/* if (irshft .ne. 0) then */
/* c */
/* c Accid on chord note is shifted. Include only left shift, in 20ths. */
/* c */
/* if (irshft .lt. 64) icashft = max(icashft,64-irshft) */
/* end if */
/* end if */
*isarp = *isarp || bit_test(icrdat[icrd],25);
} else if (found1) {
return 0;
}
/* L18: */
}
return 0;
} /* chkarp_ */
/* Subroutine */ int chkimidi_(integer *icm)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___242 = { 0, 6, 0, 0, 0 };
static cilist io___243 = { 0, 6, 0, 0, 0 };
static cilist io___244 = { 0, 6, 0, "(a6,2x,4i8)", 0 };
if (commidi_1.imidi[*icm] >= 24576) {
s_wsle(&io___242);
e_wsle();
s_wsle(&io___243);
do_lio(&c__9, &c__1, "Midi file is too long! It will be corrupted or"
" worse", (ftnlen)52);
e_wsle();
s_wsfe(&io___244);
do_fio(&c__1, "imidi:", (ftnlen)6);
do_fio(&c__1, (char *)&commidi_1.imidi[0], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&commidi_1.imidi[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&commidi_1.imidi[2], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&commidi_1.imidi[3], (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
} /* chkimidi_ */
/* Subroutine */ int chkkbdrests_(integer *ip, integer *iv, integer *ivx,
integer *nn, integer *iornq, integer *islur, integer *irest, integer *
nolev, integer *ivmx, integer *nib, integer *nv, integer *ibar, real *
tnow, real *tol, integer *nodur, integer *mode, integer *levtopr,
integer *levbotr, integer *mult)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer i_sign(integer *, integer *);
/* Local variables */
static integer levother, kkp;
extern integer log2_(integer *), ncmid_(integer *, integer *);
static integer indxr, iraise, levbot;
static real tother;
static integer levtop, iraise1, iraise2, ivother, levnext, iupdown;
/* On 130127 put this code, formerly in make2bar right before calling notex for */
/* a single note/rest, into this subroutine, so the same logic could also be */
/* with the calls to beamstrt/mid/end to adjust height of rests in xtups if the */
/* keyboard rest option is selected */
/* mode=1 if called as before, 2 if for an xtup. Only affects check for */
/* quarter rests, which will fix later. */
/* Get reference level: next following note if no intervening blank rests, */
/* otherwise next prior note. Relative to bottom line. */
/* Parameter adjustments */
mult -= 25;
--levbotr;
--levtopr;
nodur -= 25;
nib -= 25;
ivmx -= 25;
nolev -= 25;
irest -= 25;
islur -= 25;
--iornq;
--nn;
/* Function Body */
if (*ip != nn[*ivx] && ! bit_test(iornq[*ivx + *ip * 24],30)) {
/* Not the last note and not "look-left" for level */
i__1 = nn[*ivx];
for (kkp = *ip + 1; kkp <= i__1; ++kkp) {
if (bit_test(islur[*ivx + kkp * 24],29)) {
goto L4;
}
if (! bit_test(irest[*ivx + kkp * 24],0)) {
levnext = nolev[*ivx + kkp * 24] - ncmid_(iv, &kkp) + 4;
/* Relative to botto */
goto L9;
}
/* L8: */
}
}
L4:
/* If here, there were no following notes or came to a blank rest, or */
/* "look-left" option set. So look before */
/* if (ip .eq. 1) go to 2 ! Get out if this is the first note. */
if (*ip == 1) {
return 0;
}
/* Get out if this is the first note. */
for (kkp = *ip - 1; kkp >= 1; --kkp) {
if (! bit_test(irest[*ivx + kkp * 24],0)) {
levnext = nolev[*ivx + kkp * 24] - ncmid_(iv, &kkp) + 4;
/* Relative to bottom */
goto L9;
}
/* L3: */
}
/* go to 2 ! Pretty odd, should never be here, but get out if so. */
return 0;
/* Pretty odd, should never be here, but get out if so. */
L9:
/* Find note in other voice at same time */
i__1 = *ivx - *nv - 1;
iupdown = i_sign(&c__1, &i__1);
ivother = ivmx[*iv + (3 - iupdown) / 2 * 24];
tother = 0.f;
i__1 = nib[ivother + *ibar * 24];
for (kkp = 1; kkp <= i__1; ++kkp) {
if ((r__1 = tother - *tnow, dabs(r__1)) < *tol) {
goto L6;
}
tother += nodur[ivother + kkp * 24];
/* L5: */
}
/* If here, then no note starts in other voice at same time, so set default */
levother = -iupdown * 50;
goto L7;
L6:
/* If here, have just identified a simultaneous note or rest in other voice */
if (! bit_test(irest[ivother + kkp * 24],0)) {
/* Not a rest, use it */
levother = nolev[ivother + kkp * 24] - ncmid_(iv, ip) + 4;
} else {
if (nodur[ivother + kkp * 24] == nodur[*ivx + *ip * 24]) {
/* Rest in other voice has same duration, get out (so defualt spacing is used) */
/* go to 2 */
return 0;
}
levother = -iupdown * 50;
}
L7:
if (*mode == 1) {
indxr = log2_(&nodur[*ivx + *ip * 24]) + 1;
} else {
/* nodu = 2**(4-(iand(mult(ivx,ip),15)-8)) */
indxr = 4 - ((mult[*ivx + *ip * 24] & 15) - 8) + 1;
}
if (iupdown < 0) {
levtop = levtopr[indxr];
iraise1 = levother - levtop - 3;
/* Based on other note */
iraise2 = levnext - levtop;
/* Based on following note */
if (indxr == 5 && levnext < 1) {
iraise2 += 2;
}
iraise = min(iraise1,iraise2);
if ((iraise + 50) % 2 == 1 && iraise + levtop > -1) {
--iraise;
}
} else {
levbot = levbotr[indxr];
iraise1 = levother - levbot + 3;
iraise2 = levnext - levbot;
if (indxr == 5 && levnext > 8) {
--iraise2;
}
iraise = max(iraise1,iraise2);
if ((iraise + 50) % 2 == 1 && iraise + levbot <= 9) {
--iraise;
}
}
nolev[*ivx + *ip * 24] = iraise + 100;
return 0;
} /* chkkbdrests_ */
/* Subroutine */ int chklit_(char *lineq, integer *iccount, integer *literr,
ftnlen lineq_len)
{
/* System generated locals */
char ch__1[1];
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char charq[1];
static integer itype, lenlit;
extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen,
ftnlen);
*literr = 0;
itype = 1;
L17:
g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
chax_(ch__1, (ftnlen)1, &c__92);
if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) {
++itype;
/* if (itype .eq. 2) then */
/* if (iccount .ne. 2 ) then */
/* c */
/* c type 2 or 3 tex string not starting in column 1 */
/* c */
/* literr = 3 */
/* return */
/* end if */
/* else if (itype .gt. 3) then */
if (itype > 3) {
*literr = 1;
return 0;
}
goto L17;
}
lenlit = itype;
L18:
g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
chax_(ch__1, (ftnlen)1, &c__92);
if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) {
g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq != ' ') {
/* Starting a new tex command withing the string */
lenlit += 2;
if (lenlit > 128) {
*literr = 2;
return 0;
}
goto L18;
}
} else {
++lenlit;
if (lenlit > 128) {
*literr = 2;
return 0;
}
goto L18;
}
return 0;
} /* chklit_ */
/* Subroutine */ int chkpm4ac_(char *lineq, integer *iccount, integer *nacc,
logical *moved, ftnlen lineq_len)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen), i_nint(real *);
/* Local variables */
static integer ipm;
static real fnum;
static char durq[1];
static integer icsav;
static logical ishorz;
extern /* Subroutine */ int readnum_(char *, integer *, char *, real *,
ftnlen, ftnlen), setbits_(integer *, integer *, integer *,
integer *);
/* Called after getting +/-/ in a note (not rest). iccount is on the +-<>. */
/* Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits */
/* 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed */
/* numbers. If moved=.true., iccount on exit is on end of last number. */
/* If moved=.false., iccount still on +/- */
i__1 = *iccount - 2;
i__2 = *iccount;
if (i_indx("sfnA", lineq + i__1, (ftnlen)4, *iccount - 1 - i__1) > 0 &&
i_indx("0123456789.", lineq + i__2, (ftnlen)11, *iccount + 1 -
i__2) > 0) {
/* Prior char was accid & next is #; this may be start of accidental shift. */
/* Must test for "." above in case we get "<" or ">" */
ipm = i_indx("- +< >", lineq + (*iccount - 1), (ftnlen)6, (ftnlen)1)
- 2;
i__1 = *iccount + 1;
i__2 = *iccount;
if (s_cmp(lineq + i__2, ".", *iccount + 1 - i__2, (ftnlen)1) == 0 &&
i_indx("0123456789", lineq + i__1, (ftnlen)10, *iccount + 2 -
i__1) == 0) {
/* Rare case of [accid][+/-].[letter]. Bail out */
*moved = FALSE_;
return 0;
}
ishorz = ipm > 1;
/* Save iccount in case it's not accid shift and we have to reset. */
icsav = *iccount;
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (ishorz || i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* This has to be accidental shift. Set vert. shift. */
if (! ishorz) {
/* +/- syntax, both shifts set, vertical first */
i__1 = (integer) (ipm * fnum + 32.5f);
setbits_(nacc, &c__6, &c__4, &i__1);
ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) - 2;
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
} else {
/* syntax, only horiz set */
ipm += -3;
}
/* Set horiz. shift */
r__1 = (ipm * fnum + 5.35f) * 20;
i__1 = i_nint(&r__1);
setbits_(nacc, &c__7, &c__10, &i__1);
--(*iccount);
*moved = TRUE_;
} else {
/* False alarm. Reset everything and flow onward */
*moved = FALSE_;
*iccount = icsav;
}
} else {
/* Either prior char was not 'sfn' or next was not digit, so take no action */
*moved = FALSE_;
}
return 0;
} /* chkpm4ac_ */
/* Subroutine */ int clefsym_(integer *isl, char *notexq, integer *lnote,
integer *nclef, ftnlen notexq_len)
{
/* System generated locals */
address a__1[4];
integer i__1[4], i__2, i__3;
char ch__1[1], ch__2[1], ch__3[1];
/* Builtin functions */
integer lbit_shift(integer, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nlev;
/* Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. */
*nclef = lbit_shift(*isl, (ftnlen)-12) & 7;
if (*nclef == 0) {
/* treble */
nlev = 2;
} else if (*nclef > 6) {
/* French violin */
nlev = 0;
} else if (*nclef < 5) {
/* C-clef */
nlev = (*nclef << 1) - 2;
} else {
/* F-clef */
nlev = (*nclef << 1) - 6;
}
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 7, a__1[1] = "pmxclef";
i__2 = min(*nclef,7) + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__1[2] = 1, a__1[2] = ch__2;
i__3 = nlev + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__1[3] = 1, a__1[3] = ch__3;
s_cat(notexq, a__1, i__1, &c__4, notexq_len);
*lnote = 10;
return 0;
} /* clefsym_ */
/* Subroutine */ int crdacc_(integer *nacc, integer *naccid, integer *micrd,
integer *nolevm, real *rmsshift, logical *lasttime, integer *
levmaxacc, integer *icrdot0, real *segrb0, integer *ksegrb0, integer *
nsegrb0, logical *twooftwo, integer *icashft)
{
/* Initialized data */
static integer nsegar[5] = { 3,4,3,3,2 };
static integer nsegal[5] = { 2,4,3,3,2 };
static real segar[60] /* was [5][2][6] */ = { -.05f,-.38f,-.34f,
-.05f,-.15f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,-.75f,-.2f,-.8f,-.75f,
0.f,.96f,-1.04f,1.48f,.96f,1.2f,0.f,-.38f,0.f,0.f,0.f,3.15f,1.64f,
3.f,3.15f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f };
static real segal[60] /* was [5][2][6] */ = { -1.f,-1.02f,-.6f,
-1.65f,-1.2f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,0.f,-1.2f,-1.04f,0.f,
0.f,3.15f,-1.64f,-1.48f,3.15f,1.2f,0.f,-1.02f,0.f,0.f,0.f,0.f,
1.04f,3.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f };
static integer iacctbl[6] = { 1,2,3,0,4,5 };
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
/* Builtin functions */
integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *,
char *, ftnlen), e_wsle(void);
/* Local variables */
static integer iacctype;
static logical mainnote;
extern integer igetbits_(integer *, integer *, integer *);
static real ybotaseg, shiftmin;
static integer isetshft[10];
static real ytopaseg;
static integer ibelowbot, ibelowtop, iwa, iranksetter, iseg;
extern /* Subroutine */ int stop1_(void);
static integer isega;
static real segrb[100] /* was [2][50] */;
static integer irank;
static real shift;
static integer nolev, isegrb, ksegrb[50], nsegrb, ishift;
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer netgain;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___291 = { 0, 6, 0, 0, 0 };
static cilist io___292 = { 0, 6, 0, 0, 0 };
/* nacc = accidental bitmap for main note */
/* naccid = # of accid's in chord */
/* micrd = array with icrd #'s for notes w/ acc's, 0=>main note */
/* nolevm = level of main note */
/* segrb(1|2,.) x|y-coord of right-bdry segment */
/* ksegrb(.) internal use; tells what defined this segment */
/* -2: Left-shifted notehead */
/* -1: Original right boundary */
/* 0: Main note accidental */
/* icrd: Chord-note accidental */
/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */
/* icrdot0 = top-down level-rank of main note among accid-notes */
/* icrdot(icrd)(27-29) = level rank of chord-note among accid-notes */
/* twooftwo will be true 2nd time thru; signal to store shifts w/ notes */
/* Parameter adjustments */
--ksegrb0;
segrb0 -= 3;
--micrd;
/* Function Body */
/* Fancy sharp boundary. fl,sh,na,dfl,dsh */
/* * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , */
/* meas value for y, natural is 1.6 */
/* * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , */
/* c (meas. value is 3.08) ^^^^ */
/* c Raise top of flat so it interferes with bottom of sharp */
/* iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) */
/* Set up barrier segrb(iseg,ipoint) to define coords of corner points */
/* on stem+notes */
i__1 = *nsegrb0;
for (iseg = 1; iseg <= i__1; ++iseg) {
segrb[(iseg << 1) - 2] = segrb0[(iseg << 1) + 1];
segrb[(iseg << 1) - 1] = segrb0[(iseg << 1) + 2];
ksegrb[iseg - 1] = ksegrb0[iseg];
/* L11: */
}
nsegrb = *nsegrb0;
*rmsshift = 0.f;
shiftmin = 1e3f;
i__1 = *naccid;
for (iwa = 1; iwa <= i__1; ++iwa) {
/* Initialize shift for this note */
shift = 0.f;
mainnote = micrd[iwa] == 0;
isetshft[iwa - 1] = -1;
/* Get note level and accidental type */
if (mainnote) {
nolev = *nolevm;
iacctype = iacctbl[igetbits_(nacc, &c__3, &c__0) - 1];
} else {
nolev = igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], &c__7, &
c__12);
iacctype = iacctbl[igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], &
c__3, &c__20) - 1];
}
/* Cycle thru segments on right edge of this accidental */
i__2 = nsegar[iacctype - 1] - 1;
for (isega = 1; isega <= i__2; ++isega) {
ybotaseg = nolev + segar[iacctype + ((isega << 1) + 2) * 5 - 16];
ytopaseg = nolev + segar[iacctype + ((isega + 1 << 1) + 2) * 5 -
16];
/* Cycle thru segments of right-hand barrier */
i__3 = nsegrb - 1;
for (isegrb = 1; isegrb <= i__3; ++isegrb) {
/* Must find all barrier segments that start below ytopseg & end above ybotseg */
if (segrb[(isegrb << 1) - 1] < ytopaseg) {
/* Barrier seg starts below top of accid */
/* Check if barrier seg ends above bottom of accid */
if (segrb[(isegrb + 1 << 1) - 1] > ybotaseg) {
if (shift > segrb[(isegrb << 1) - 2] - segar[iacctype
+ ((isega << 1) + 1) * 5 - 16]) {
shift = segrb[(isegrb << 1) - 2] - segar[iacctype
+ ((isega << 1) + 1) * 5 - 16];
/* Record the cause of the shift */
isetshft[iwa - 1] = ksegrb[isegrb - 1];
}
}
/* Does barrier segment end above top of accid seg? */
if (segrb[(isegrb + 1 << 1) - 1] > ytopaseg) {
goto L4;
}
}
/* L3: */
}
L4:
/* L2: */
;
}
if (! bit_test(*nacc,28) && dabs(shift) > 1e-4f && ! (*lasttime)) {
/* if (nolev .eq. levmaxacc) then */
if (nolev == *levmaxacc && isetshft[iwa - 1] == -1) {
*rmsshift = 1e3f;
return 0;
}
/* Does the following properly account for left-shifted noteheads? */
/* Top-down rank of this note we just shifted */
if (mainnote) {
irank = *icrdot0;
} else {
irank = igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__3, &
c__27);
}
/* Compare level-rank of this note vs. that of note that caused the shift. */
/* This has effect of checking for basic interferences from top down. */
/* ksegrb(.) internal use; tells what defined this segment */
/* -2: Left-shifted notehead */
/* -1: Original right boundary */
/* 0: Main note accidental */
/* icrd: Chord-note accidental */
/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */
if (isetshft[iwa - 1] < 0) {
iranksetter = 0;
} else if (isetshft[iwa - 1] == 0) {
iranksetter = *icrdot0;
} else {
iranksetter = igetbits_(&comtrill_1.icrdot[isetshft[iwa - 1]
- 1], &c__3, &c__27);
}
if (iranksetter != 0 && irank != iranksetter + 1) {
*rmsshift = 1e3f;
return 0;
}
}
/* Computing 2nd power */
r__1 = shift;
*rmsshift += r__1 * r__1;
if (*lasttime && dabs(shift) > 1e-4f) {
if (mainnote) {
if (! bit_test(*nacc,29)) {
goto L10;
}
} else {
if (! bit_test(comtrill_1.icrdat[micrd[iwa] - 1],29)) {
goto L10;
}
}
/* If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there */
/* was a manual shift but auto-shift was zero, will not come thru here, but shift value */
/* will be left intact. */
if (mainnote) {
shift += (igetbits_(nacc, &c__7, &c__10) - 107) * .05f;
} else {
shift += (igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7,
&c__20) - 107) * .05f;
}
L10:
if (*twooftwo) {
/* Record the shift for this accidental */
if (shift < -5.35f) {
printl_(" ", (ftnlen)1);
printl_("WARNING: auto-generated accidental shift too bi"
"g for PMX, ignoring", (ftnlen)66);
} else {
r__1 = (shift + 5.35f) * 20;
ishift = i_nint(&r__1);
if (mainnote) {
setbits_(nacc, &c__7, &c__10, &ishift);
} else {
setbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7, &
c__20, &ishift);
}
}
} else {
/* This is the earlier call to precrd, so need minimum shift */
shiftmin = dmin(shiftmin,shift);
}
}
/* Bail out if this is the last accidental to check */
if (iwa == *naccid) {
goto L1;
}
/* Add this accidental to the right barrier! Count down from highest barrier segment, */
/* find 1st one starting below top of accid, and first one starting below bot. */
for (ibelowtop = nsegrb; ibelowtop >= 1; --ibelowtop) {
if (segrb[(ibelowtop << 1) - 1] < nolev + segal[iacctype + ((
nsegal[iacctype - 1] << 1) + 2) * 5 - 16]) {
for (ibelowbot = ibelowtop; ibelowbot >= 1; --ibelowbot) {
if (segrb[(ibelowbot << 1) - 1] < nolev + segal[iacctype
+ 4]) {
goto L6;
}
/* L9: */
}
s_wsle(&io___291);
do_lio(&c__9, &c__1, "Oops2!", (ftnlen)6);
e_wsle();
stop1_();
}
/* L5: */
}
s_wsle(&io___292);
do_lio(&c__9, &c__1, "Ugh0! in crdaccs", (ftnlen)16);
e_wsle();
stop1_();
L6:
netgain = nsegal[iacctype - 1] - ibelowtop + ibelowbot;
/* Shift high segments up */
if (netgain >= 0) {
i__2 = ibelowtop + 1;
for (isegrb = nsegrb; isegrb >= i__2; --isegrb) {
segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2];
segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1];
ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1];
/* L7: */
}
/* Set up 1st segment above accid */
segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) -
2];
segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + (
(nsegal[iacctype - 1] << 1) + 2) * 5 - 16];
ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1];
} else {
/* netgain<0, must remove segments. Use same coding but reverse order, */
/* work from bottom up */
segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) -
2];
segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + (
(nsegal[iacctype - 1] << 1) + 2) * 5 - 16];
ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1];
i__2 = nsegrb;
for (isegrb = ibelowtop + 1; isegrb <= i__2; ++isegrb) {
segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2];
segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1];
ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1];
/* L12: */
}
}
/* Insert new segments */
i__2 = nsegal[iacctype - 1] - 1;
for (isega = 1; isega <= i__2; ++isega) {
segrb[(ibelowbot + isega << 1) - 2] = shift + segal[iacctype + ((
isega << 1) + 1) * 5 - 16];
segrb[(ibelowbot + isega << 1) - 1] = nolev + segal[iacctype + ((
isega << 1) + 2) * 5 - 16];
if (mainnote) {
ksegrb[ibelowbot + isega - 1] = 0;
} else {
ksegrb[ibelowbot + isega - 1] = micrd[iwa];
}
/* L8: */
}
/* Update number of barrier segments */
nsegrb += netgain;
/* c */
/* c Temporary printout for boundary segments as built up */
/* c */
/* write(15,'()') */
/* write(15,'(a/(2f8.2,i5))')' y x kseg', */
/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */
/* write(15,'(a/(2i5))')' micrd isetshft', */
/* * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) */
/* c */
L1:
;
}
/* next accidental */
if (*lasttime && ! (*twooftwo)) {
/* This is the final call on the pre-ask pass, so compute left-shift rqmt. */
r__1 = shiftmin * -20;
*icashft = i_nint(&r__1);
}
/* c */
/* c Temporary printout for boundary segments */
/* c */
/* if (twooftwo) then */
/* write(15,'()') */
/* write(15,'(a/(2f8.2,i5))')' y x kseg', */
/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */
/* write(15,'(a/(2i5))')' micrd isetshft', */
/* * (micrd(iwa),isetshft(iwa),iwa=1,naccid) */
/* end if */
/* c */
return 0;
} /* crdacc_ */
/* Subroutine */ int crdaccs_(integer *nacc, integer *ipl, integer *irest,
integer *naccid, integer *kicrd, integer *nolevm, integer *levmaxacc,
integer *levminacc, integer *icrdot0, logical *twooftwo, integer *
icashft)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static integer ipermsav[7];
static real rmsshift;
static integer i__, j, k, levmidacc, ip, ir, is, it, maxmanshft, icrd;
extern /* Subroutine */ int stop1_(void);
static integer micrd[10], iiseg, irank, iperm[7], nolev;
static real segrb0[100] /* was [2][50] */;
extern /* Subroutine */ int crdacc_(integer *, integer *, integer *,
integer *, real *, logical *, integer *, integer *, real *,
integer *, integer *, logical *, integer *);
static logical tagged;
static integer isegrb;
static logical manual, lshift;
static integer idummy;
static real rmsmin;
static integer ksegrb0[50], nsegrb0, manshft;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___321 = { 0, 6, 0, 0, 0 };
/* nacc = accidental bitmap for main note */
/* naccid = # of accid's in chord */
/* kicrd = array with icrd #'s for notes w/ acc's, 0=>main note */
/* nolevm = level of main note */
/* This is called once per multi-accidental chord. In here, loop over all */
/* permutations of the order of accidental as stored in kicrd. Each time thru */
/* loop, call crdacc once, get rms shift. Only save permutation and rms value */
/* if it is less than old value. */
/* Make consistent? 120106 */
/* integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) */
/* c */
/* c Temporary printout of level-rankings */
/* c */
/* write(15,'()') */
/* do 98 iacc = 1 , naccid */
/* if (kicrd(iacc) .eq. 0) then */
/* write(15,'(3i5)')nolevm,icrdot0 */
/* else */
/* write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), */
/* * igetbits(icrdot(kicrd(iacc)),3,27) */
/* end if */
/* 98 continue */
/* c */
/* Initialize right-barrier */
/* Parameter adjustments */
--kicrd;
/* Function Body */
segrb0[0] = 0.f;
segrb0[1] = -1e3f;
segrb0[2] = 0.f;
segrb0[3] = 1e3f;
nsegrb0 = 2;
ksegrb0[0] = -1;
ksegrb0[1] = -1;
/* Search for left-shifted notes, Make up the initial right-barrier, which */
/* will be good for all permutations. */
/* irest()(27) is set if any notes are left-shifted */
/* Must use ALL chord notes, not just ones w/ accid's. */
if (bit_test(*irest,27)) {
i__1 = comtrill_1.icrd2;
for (icrd = comtrill_1.icrd1 - 1; icrd <= i__1; ++icrd) {
if (icrd == comtrill_1.icrd1 - 1) {
/* Main note */
/* lshift = btest(ipl,8) */
lshift = bit_test(*ipl,8) || bit_test(*nacc,31);
if (lshift) {
nolev = *nolevm;
}
} else {
/* Chord note */
lshift = bit_test(comtrill_1.icrdat[icrd - 1],23);
/* if (lshift) nolev = igetbits(icrdat(icrd),7,12) */
if (lshift) {
nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &
c__12);
if (bit_test(*nacc,31) && nolev == *nolevm + 1) {
/* This note is not really shifted, It is the upper of a 2nd with the main */
/* note on an upstem, and Main note must be shifted. */
/* nacc(31) signals the real truth. */
lshift = FALSE_;
}
}
}
if (lshift) {
i__2 = nsegrb0 - 1;
for (isegrb = 1; isegrb <= i__2; ++isegrb) {
if (segrb0[(isegrb + 1 << 1) - 1] > (real) (nolev - 1)) {
/* Add this notehead to the right boundary here. Move all higher segs up 2. */
i__3 = isegrb + 1;
for (iiseg = nsegrb0; iiseg >= i__3; --iiseg) {
segrb0[(iiseg + 2 << 1) - 2] = segrb0[(iiseg << 1)
- 2];
segrb0[(iiseg + 2 << 1) - 1] = segrb0[(iiseg << 1)
- 1];
ksegrb0[iiseg + 1] = ksegrb0[iiseg - 1];
/* L17: */
}
goto L18;
}
/* L16: */
}
L18:
/* Insert notehead into list. Set kseg=-2 to signal notehead shift. */
iiseg = isegrb + 1;
segrb0[(iiseg << 1) - 2] = -1.2f;
segrb0[(iiseg << 1) - 1] = nolev - 1.f;
ksegrb0[iiseg - 1] = -2;
segrb0[(iiseg + 1 << 1) - 2] = 0.f;
segrb0[(iiseg + 1 << 1) - 1] = nolev + 1.f;
ksegrb0[iiseg] = -1;
nsegrb0 += 2;
}
/* L15: */
}
}
/* Done setting right barrier for left-shifted noteheads */
tagged = FALSE_;
manual = FALSE_;
/* Preprocess to check for manual shifts. */
/* If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then */
/* If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then */
/* 1. Auto-shifting proceeds */
/* 2. "A"-shifts add to autoshifts */
/* 3. non-"A" shifts are ignored! */
/* Else (>0 man shifts, none has "A") */
/* No auto-ordering, No autoshifts, Observe all manual shifts. */
/* End if */
/* End if */
maxmanshft = 0;
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
if (kicrd[i__] == 0) {
/* Main note */
manshft = igetbits_(nacc, &c__7, &c__10);
if (manshft != 0) {
manual = TRUE_;
if (bit_test(*nacc,29)) {
tagged = TRUE_;
} else {
/* maxmanshft = max(maxmanshft,64-manshft) */
/* Computing MAX */
i__2 = maxmanshft, i__3 = 107 - manshft;
maxmanshft = max(i__2,i__3);
}
}
} else {
/* Chord note */
manshft = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, &
c__20);
if (manshft != 0) {
manual = TRUE_;
if (bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) {
tagged = TRUE_;
} else {
/* maxmanshft = max(maxmanshft,64-manshft) */
/* Computing MAX */
i__2 = maxmanshft, i__3 = 107 - manshft;
maxmanshft = max(i__2,i__3);
}
}
}
/* L13: */
}
if (manual) {
if (tagged) {
/* zero out all untagged shifts */
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
if (kicrd[i__] == 0) {
if (! bit_test(*nacc,29)) {
setbits_(nacc, &c__7, &c__10, &c__0);
}
} else {
if (! bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) {
setbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, &
c__20, &c__0);
}
}
/* L14: */
}
} else {
/* There are manual shifts but none tagged. Only proceed if "Ao" was entered */
if (! bit_test(*nacc,28)) {
*icashft = maxmanshft;
return 0;
}
}
}
if (bit_test(*nacc,28)) {
/* Take the accidentals in order as originally input, then exit. */
crdacc_(nacc, naccid, &kicrd[1], nolevm, &rmsshift, &c_true, &idummy,
&idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft);
return 0;
/* end if */
} else if (*naccid == 3) {
/* Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd */
/* then place in order top, bottom, middle. */
for (i__ = 1; i__ <= 3; ++i__) {
if (kicrd[i__] == 0) {
irank = *icrdot0;
nolev = *nolevm;
} else {
irank = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__3, &
c__27);
nolev = igetbits_(&comtrill_1.icrdat[kicrd[i__] - 1], &c__7, &
c__12);
}
if (irank == 1) {
micrd[0] = kicrd[i__];
} else {
micrd[5 - irank - 1] = kicrd[i__];
}
if (irank == 2) {
levmidacc = nolev;
}
/* L20: */
}
if (*levmaxacc != levmidacc + 1 && levmidacc != *levminacc + 1) {
crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy,
&idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft);
return 0;
}
}
rmsmin = 1e5f;
/* Initialize permutation array */
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
iperm[i__ - 1] = i__;
/* L7: */
}
/* Start looping over permutations */
for (ip = 1; ip <= 5041; ++ip) {
if (ip != 1) {
/* Work the magic algorithm to get the next permutation */
for (k = *naccid - 1; k >= 1; --k) {
if (iperm[k - 1] <= iperm[k]) {
goto L2;
}
/* L1: */
}
/* If here, we just got the last permutation, so exit the loop over permutations */
goto L10;
L2:
for (j = *naccid; j >= 1; --j) {
if (iperm[k - 1] <= iperm[j - 1]) {
goto L4;
}
/* L3: */
}
L4:
it = iperm[j - 1];
iperm[j - 1] = iperm[k - 1];
iperm[k - 1] = it;
is = k + 1;
for (ir = *naccid; ir >= 1; --ir) {
if (ir <= is) {
goto L6;
}
it = iperm[ir - 1];
iperm[ir - 1] = iperm[is - 1];
iperm[is - 1] = it;
++is;
/* L5: */
}
L6:
;
}
/* New we have a permutation. Take icrd values out of kicrd and put them into */
/* micrd in the order of the permutation */
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
micrd[i__ - 1] = kicrd[iperm[i__ - 1]];
/* L9: */
}
/* c */
/* c Temporary printout */
/* c */
/* write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) */
/* c */
crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_false, levmaxacc,
icrdot0, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft);
/* c */
/* c Temporary printout */
/* c */
/* write(15,*)'perm done, rmsshift:',rmsshift */
/* c */
if (rmsshift < rmsmin) {
/* Save this permutation, reset minrms */
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
ipermsav[i__ - 1] = iperm[i__ - 1];
rmsmin = rmsshift;
/* L11: */
}
}
/* L8: */
}
s_wsle(&io___321);
do_lio(&c__9, &c__1, "Should not BEEEEEE here!", (ftnlen)24);
e_wsle();
stop1_();
L10:
/* Done looping, get info for the final choice */
i__1 = *naccid;
for (i__ = 1; i__ <= i__1; ++i__) {
micrd[i__ - 1] = kicrd[ipermsav[i__ - 1]];
/* L12: */
}
/* c */
/* c Temporary printout */
/* c */
/* write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) */
/* c */
crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy, &idummy,
segrb0, ksegrb0, &nsegrb0, twooftwo, icashft);
return 0;
} /* crdaccs_ */
/* Subroutine */ int doacc_(integer *ihshft, integer *ivshft, char *notexq,
integer *lnote, integer *nacc, integer *nolev, integer *ncm, logical *
caut, ftnlen notexq_len)
{
/* System generated locals */
address a__1[2], a__2[3];
integer i__1[2], i__2[3];
char ch__1[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static char sq[1];
static integer lacc;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static real hshft;
static char noteq[8];
extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen);
static integer noleva;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static char acsymq[3];
static integer lnoten;
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
if (*ihshft == -107) {
*ihshft = 0;
}
/* c */
/* c If main note shifted left, so shift accid. Terminate below, when acc. is done. */
/* c */
if (*ihshft != 0) {
/* Accid must be shifted horizontally */
if (*ihshft < 0) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 8, a__1[1] = "loffset{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*ihshft = -(*ihshft);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 8, a__1[1] = "roffset{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
}
hshft = *ihshft * .05f;
if (hshft < 1.f) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 3;
ici__1.iciunit = notexq + 9;
ici__1.icifmt = "(f3.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real));
e_wsfi();
*lnote = 12;
} else {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = notexq + 9;
ici__1.icifmt = "(f4.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real));
e_wsfi();
*lnote = 13;
}
/* Writing concatenation */
i__2[0] = *lnote, a__2[0] = notexq;
i__2[1] = 2, a__2[1] = "}{";
i__2[2] = 1, a__2[2] = sq;
s_cat(notexq, a__2, i__2, &c__3, (ftnlen)79);
*lnote += 3;
} else {
s_copy(notexq, sq, (ftnlen)79, (ftnlen)1);
*lnote = 1;
}
if (bit_test(*nacc,3)) {
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = 3, a__1[1] = "big";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote += 3;
}
if (*caut) {
/* Cautionary accidental. Need to define bigcna,... in pmx.tex */
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = "c";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
++(*lnote);
}
accsym_(nacc, acsymq, &lacc, (ftnlen)3);
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = lacc, a__1[1] = acsymq;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote += lacc;
noleva = *nolev;
if (*ivshft != 0) {
noleva = noleva + *ivshft - 32;
}
notefq_(noteq, &lnoten, &noleva, ncm, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = lnoten, a__1[1] = noteq;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote += lnoten;
if (*ihshft != 0) {
/* Terminate horizontal shift */
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
++(*lnote);
}
return 0;
} /* doacc_ */
/* Subroutine */ int docrd_(integer *ivx, integer *ip, integer *nodu, integer
*ncm, integer *iv, real *tnow, char *soutq, integer *lsout, char *ulq,
integer *ibmcnt, integer *islur, integer *nvmx, integer *nv, logical
*beamon, integer *nolevm, integer *ihornb, integer *nornb, real *
stemlen, logical *dotxtup, integer *nacc, ftnlen soutq_len, ftnlen
ulq_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3[2], i__4, i__5, i__6;
logical L__1;
char ch__1[1];
/* Builtin functions */
integer pow_ii(integer *, integer *), lbit_shift(integer, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
extern integer igetbits_(integer *, integer *, integer *);
static integer kv;
extern integer log2_(integer *);
static integer icrd;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer lout, lsym;
static char outq[79];
extern /* Subroutine */ int stop1_(void), doacc_(integer *, integer *,
char *, integer *, integer *, integer *, integer *, logical *,
ftnlen);
extern integer ncmid_(integer *, integer *);
static integer lnote, nolev;
static char noteq[8];
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer nactmp;
static logical isleft;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static real updotc, rtdotc;
static integer nolevo, lnoten;
extern /* Subroutine */ int dotmov_(real *, real *, char *, integer *,
integer *, ftnlen), putarp_(real *, integer *, integer *, integer
*, integer *, char *, integer *, ftnlen);
static char notexq[79], nosymq[7];
extern /* Subroutine */ int putorn_(integer *, integer *, integer *,
integer *, integer *, char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, char *,
integer *, integer *, integer *, logical *, logical *, ftnlen,
ftnlen), addmidi_(integer *, integer *, integer *, integer *,
real *, logical *, logical *);
static logical isright;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___346 = { 0, 6, 0, 0, 0 };
static cilist io___347 = { 0, 6, 0, 0, 0 };
/* 130316 */
/* This subr. once produced notexq for entire chord. 10/18/97 altered to write */
/* chord notes as we go. 10/22/97 find range of icrd first. */
/* 2/25/98 moved rangefinding to precrd so done before slurs, so now */
/* on entry, icrd1, icrd2 define range of icrd for this chord. */
/* Set counter (for this note) for chord notes present. Set notmain=T. */
/* Will test for notmain=.true. in addmidi to tell whether to save pitch. */
/* Parameter adjustments */
--nornb;
ihornb -= 25;
ulq -= 25;
/* Function Body */
commidi_1.nmidcrd = 0;
commidi_1.notmain = TRUE_;
commidi_1.crdacc = FALSE_;
i__1 = comtrill_1.icrd2;
for (icrd = comtrill_1.icrd1; icrd <= i__1; ++icrd) {
lnote = 0;
nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12);
/* 3/8/03 save original pitch to use in midi, in case 2nds alter things. */
nolevo = nolev;
/* Check for special situations with 2nds (see precrd). */
if (bit_test(*nacc,30)) {
if (nolev == *nolevm - 1) {
nolev = *nolevm;
}
} else if (bit_test(*nacc,31)) {
if (nolev == *nolevm + 1) {
nolev = *nolevm;
}
}
/* Lower dot for lower-voice notes?. Conditions are: */
/* 1. Dotted time value */
/* 2. Lower voice of two */
/* 3. Note is on a line */
/* 4. Not a rest (cannot be a rest in a chord!) */
/* . 5. Flag (lowdot) is set to true */
if (comarp_1.lowdot && *nvmx == 2 && *ivx <= *nv) {
i__2 = log2_(nodu);
if (pow_ii(&c__2, &i__2) != *nodu && (nolev - *ncm) % 2 == 0) {
if (bit_test(comtrill_1.icrdat[icrd - 1],26)) {
/* Note already in movdot list. Drop by 2. */
i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &
c__0) - 20;
setbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__0, &
i__2);
} else {
/* Not in list so just move it right now */
i__2 = igetbits_(islur, &c__1, &c__3);
dotmov_(&c_b761, &c_b762, soutq, lsout, &i__2, (ftnlen)80)
;
}
}
}
if (bit_test(comtrill_1.icrdat[icrd - 1],26)) {
/* Move the dot. */
updotc = ((127 & comtrill_1.icrdot[icrd - 1]) - 64) * .1f;
rtdotc = ((127 & lbit_shift(comtrill_1.icrdot[icrd - 1], (ftnlen)
-7)) - 64) * .1f;
i__2 = igetbits_(islur, &c__1, &c__3);
dotmov_(&updotc, &rtdotc, soutq, lsout, &i__2, (ftnlen)80);
}
isleft = bit_test(comtrill_1.icrdat[icrd - 1],23);
isright = bit_test(comtrill_1.icrdat[icrd - 1],24);
/* Check for ornament in chord. */
if (comtrill_1.icrdorn[icrd - 1] > 0) {
putorn_(&comtrill_1.icrdorn[icrd - 1], &nolev, nolevm, nodu, &
nornb[1], ulq + 25, ibmcnt, ivx, ncm, islur, nvmx, nv, &
ihornb[25], stemlen, outq, &lout, ip, &c__0, beamon, &
c_true, (ftnlen)1, (ftnlen)79);
/* subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, */
/* * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, */
/* * notcrd,beamon,iscrd) */
addstr_(outq, &lout, soutq, lsout, (ftnlen)79, (ftnlen)80);
}
/* Chord-note symbol. First check for breve */
if (*nodu == 128) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "zbreve";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
lsym = 7;
} else {
/* Not a breve chord. Get first letters in chord-note symbol */
if (isleft) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 1, a__1[1] = "l";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
} else if (isright) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 1, a__1[1] = "r";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 1, a__1[1] = "z";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
}
if (*nodu >= 64) {
/* Writing concatenation */
i__3[0] = 2, a__1[0] = nosymq;
i__3[1] = 1, a__1[1] = "w";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
} else if (*nodu >= 32) {
/* Writing concatenation */
i__3[0] = 2, a__1[0] = nosymq;
i__3[1] = 1, a__1[1] = "h";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
} else {
/* Writing concatenation */
i__3[0] = 2, a__1[0] = nosymq;
i__3[1] = 1, a__1[1] = "q";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
}
i__2 = log2_(nodu);
if (pow_ii(&c__2, &i__2) == *nodu && ! (*dotxtup)) {
lsym = 3;
} else if (! bit_test(*islur,3) || *dotxtup) {
/* Single dot */
/* Writing concatenation */
i__3[0] = 3, a__1[0] = nosymq;
i__3[1] = 1, a__1[1] = "p";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
lsym = 4;
} else {
/* Double dot */
/* Writing concatenation */
i__3[0] = 3, a__1[0] = nosymq;
i__3[1] = 2, a__1[1] = "pp";
s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7);
lsym = 5;
}
}
if (bit_test(comtrill_1.icrdat[icrd - 1],19) && ! bit_test(
comtrill_1.icrdat[icrd - 1],27)) {
/* Accidental and not MIDI-only. Build up bits 0-3 of nacc */
nactmp = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20);
/* Kluge for bigness. Only means 'As' has not been issued */
if (spfacs_1.bacfac != 1e6f) {
nactmp += 8;
}
i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__20) -
107;
i__4 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__6, &c__14);
i__5 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12);
i__6 = ncmid_(iv, ip);
L__1 = bit_test(comtrill_1.icrdat[icrd - 1],31);
doacc_(&i__2, &i__4, notexq, &lnote, &nactmp, &i__5, &i__6, &L__1,
(ftnlen)79);
/* * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) */
/* Get original nolev, not altered to deal with 2nds */
/* * ncmid(iv,ip)) */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 7, a__1[1] = nosymq;
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
commidi_1.crdacc = TRUE_;
} else {
s_copy(notexq, nosymq, (ftnlen)79, (ftnlen)7);
}
lnote += lsym;
/* Get note name (again if accid, due to possible octave jump) */
notefq_(noteq, &lnoten, &nolev, ncm, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
/* Put in note name */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 8, a__1[1] = noteq;
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote += lnoten;
if (bit_test(comtrill_1.icrdat[icrd - 1],25)) {
/* Arpeggio signal */
/* call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) */
putarp_(tnow, ivx, ip, &nolev, ncm, soutq, lsout, (ftnlen)80);
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
if (commidi_1.ismidi) {
/* Here is where we collect MIDI pitch info for the chord note. By checking */
/* notmain, addmidi(...) knows to just compute the */
/* pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() */
/* for MAIN note, will put in note codes for all chord notes + main note. */
kv = 1;
if (*ivx > *iv) {
kv = 2;
}
++commidi_1.nmidcrd;
if (commidi_1.nmidcrd > 20) {
s_wsle(&io___346);
e_wsle();
s_wsle(&io___347);
do_lio(&c__9, &c__1, "21 chord notes is too many for midi pr"
"ocessor", (ftnlen)45);
e_wsle();
stop1_();
}
/* Use original saved pitch level, unaltered by 2nds logic. */
/* 130316 */
/* call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), */
i__2 = nolevo + commvel_1.miditran[cominsttrans_1.instno[*iv - 1]
- 1];
i__4 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20);
addmidi_(&commidi_1.midchan[*iv + kv * 24 - 25], &i__2, &i__4, &
commidisig_1.midisig, &c_b807, &c_false, &c_false);
/* * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) */
/* 130316 */
/* * igetbits(icrdat(icrd),3,20),midisig(instno(iv)),1., */
}
/* L5: */
}
commidi_1.notmain = FALSE_;
return 0;
} /* docrd_ */
/* Subroutine */ int dodyn_(integer *ivx, integer *ip, integer *nolev,
integer *ncm, integer *ipl, integer *islur, integer *irest, integer *
nvmx, integer *nv, logical *beamon, integer *ihornb, integer *nornb,
char *ulq, integer *ibmcnt, logical *nostem, char *soutq, integer *
lsout, ftnlen ulq_len, ftnlen soutq_len)
{
/* Initialized data */
static char dyntablq[48] = "ppppppp pp p mp mf f fp sfz ff fff "
"ffff";
/* System generated locals */
address a__1[2], a__2[4], a__3[3], a__4[6];
integer i__1, i__2, i__3[2], i__4[4], i__5, i__6[3], i__7[6];
char ch__1[1], ch__2[6], ch__3[81], ch__4[53];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
extern /* Subroutine */ int backfill_(integer *, char *, integer *, char *
, integer *, ftnlen, ftnlen);
static integer jtxtdyn1;
extern integer igetbits_(integer *, integer *, integer *);
static integer lpretweak, id;
static real hoff;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer idno, lbot, idyn, jdyn;
extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer lbot1;
extern integer lfmt1_(real *);
extern /* Subroutine */ int stop1_(void);
static integer idynd, lform, idynn[10], lnote, ltemp;
static char tempq[48];
static integer ivxip;
static char numpq[5];
static integer idynd2;
static real hoffsd;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer iptent;
extern integer lenstr_(char *, integer *, ftnlen);
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer numdyn;
static logical upstem;
static char notexq[79];
static integer lnumpq, icntdyn, ivxtent;
static char dynstrq[4];
static integer jtxtdyn, ltxtdyn;
/* Fortran I/O blocks */
static icilist io___368 = { 0, numpq+1, 0, "(i2)", 2, 1 };
static icilist io___370 = { 0, numpq+1, 0, "(i2)", 2, 1 };
static icilist io___371 = { 0, numpq+1, 0, "(i3)", 3, 1 };
static icilist io___378 = { 0, numpq+1, 0, "(i2)", 2, 1 };
static icilist io___379 = { 0, numpq+1, 0, "(i2)", 2, 1 };
static icilist io___380 = { 0, numpq+1, 0, "(i3)", 3, 1 };
static cilist io___383 = { 0, 11, 0, "(a)", 0 };
/* Inputs are array *elements* except ihornb,nornb,ulq */
/* Parameter adjustments */
ulq -= 25;
--nornb;
ihornb -= 25;
/* Function Body */
numdyn = 0;
/* Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values */
/* in idynn(1...4) */
i__1 = comdyn_1.ndyn;
for (idyn = 1; idyn <= i__1; ++idyn) {
/* ivxtent = iand(idyndat(idyn),15) */
ivxtent = (comdyn_1.idyndat[idyn - 1] & 15) + (igetbits_(&
comdyn_1.idynda2[idyn - 1], &c__1, &c__10) << 4);
if (ivxtent == *ivx) {
iptent = igetbits_(&comdyn_1.idyndat[idyn - 1], &c__8, &c__4);
if (iptent == *ip) {
++numdyn;
idynn[numdyn - 1] = idyn;
} else if (iptent > *ip) {
/* I don't think there are any more possible for this ivx,ip, so exit loop */
goto L2;
}
/* else if (ivxtent .gt. ivx) then */
/* go to 2 */
}
/* L1: */
}
L2:
/* At this point there is a list of idyn's in idynn(1...numdyn) */
/* Compute level, and stem-dir'n-based horizontal tweaks */
hoffsd = 0.f;
/* Set upstem to false as default */
upstem = FALSE_;
if (bit_test(*irest,0)) {
/* It's a rest. Assume it doesn't go below the staff */
lbot = *ncm - 4;
} else if (! (*beamon)) {
udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, nvmx, ivx, nv);
if (*(unsigned char *)&ch__1[0] == 'u' || *nostem) {
upstem = TRUE_;
if (! bit_test(*ipl,10)) {
/* Computing MIN */
i__1 = *nolev - 1, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
} else {
/* Computing MIN */
i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
}
} else {
hoffsd = -.5f;
if (! bit_test(*ipl,10)) {
/* Computing MIN */
i__1 = *nolev - 7, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
} else {
/* Computing MIN */
i__1 = comtrill_1.minlev - 7, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
}
}
} else {
if (*(unsigned char *)&ulq[*ivx + *ibmcnt * 24] == 'u') {
upstem = TRUE_;
if (! bit_test(*ipl,10)) {
/* Computing MIN */
i__1 = *nolev - 1, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
} else {
/* Computing MIN */
i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4;
lbot = min(i__1,i__2);
}
} else {
hoffsd = -.5f;
lbot = ihornb[*ivx + nornb[*ivx] * 24] + 1;
if (lbot == 1) {
/* Kluge for non-beamed, down xtup, for which ihorb was never set. */
/* Assumes stem is shortened. */
lbot = *nolev - 5;
}
++nornb[*ivx];
}
}
lbot += -5;
jtxtdyn1 = 1;
/* Now ready to loop over current dyn's */
i__1 = numdyn;
for (icntdyn = 1; icntdyn <= i__1; ++icntdyn) {
idynd = comdyn_1.idyndat[idynn[icntdyn - 1] - 1];
idynd2 = comdyn_1.idynda2[idynn[icntdyn - 1] - 1];
idno = igetbits_(&idynd, &c__4, &c__12);
/* ivx = iand(15,idynd) */
*ivx = (15 & idynd) + (igetbits_(&idynd2, &c__1, &c__10) << 4);
/* Build the command into notex in stages. Insert name & rq'd args in order: */
/* Command name */
/* hpstrt, hpcend, hpdend, pmxdyn */
/* ivx */
/* X X X */
/* level */
/* X X X */
/* hoff */
/* X X X X */
/* d-mark */
/* X */
if (idno == 0) {
/* Text-dynamic */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "txtdyn";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 7;
} else if (idno <= 12) {
/* Letter-group */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "pmxdyn";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 7;
} else if (comslur_1.fontslur) {
lnote = 7;
if (idno == 13) {
/* Start a hairpin */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "hpstrt";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
} else if (idno == 14) {
/* End crescendo */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "hpcend";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
} else {
/* End decrescendo */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "hpdend";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
}
} else {
/* Postscript hairpins */
lnote = 7;
if (idno == 13) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "Icresc";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
} else if (idno == 14) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 8, a__1[1] = "Idecresc";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 9;
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "Tcresc";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
}
}
if (idno >= 13) {
/* Put in voice number */
if (*ivx <= 9) {
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
*(unsigned char *)&ch__1[0] = *ivx + 48;
i__3[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
++lnote;
} else if (*ivx <= 19) {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{1";
*(unsigned char *)&ch__1[0] = *ivx + 38;
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{2";
*(unsigned char *)&ch__1[0] = *ivx + 28;
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
}
}
/* Begin setting level */
lbot1 = lbot;
if (idno > 0 && idno <= 5) {
/* All letters are short so raise a bit. */
++lbot1;
} else if (idno >= 13) {
lbot1 += 2;
}
/* Convert so reference is bottom line */
lbot1 = lbot1 - *ncm + 4;
if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno
== 13 || idno == 14)) {
/* Hairpin start. Save level and user-tweak before applying user tweak. */
comdyn_1.levdsav[*ivx - 1] = lbot1;
comdyn_1.levhssav[*ivx - 1] = 0;
if (bit_test(idynd,16)) {
comdyn_1.levhssav[*ivx - 1] = igetbits_(&idynd, &c__7, &c__17)
- 64;
}
} else if (comslur_1.fontslur && idno >= 14 || idno == 15) {
/* Hairpin end; Compare level with saved start level before user-tweaks */
/* Computing MIN */
i__2 = lbot1, i__5 = comdyn_1.levdsav[*ivx - 1];
lbot1 = min(i__2,i__5);
/* Save pre-tweak level */
lpretweak = lbot1;
}
/* Check for user-defined vertical tweak */
if (bit_test(idynd,16)) {
lbot1 = lbot1 - 64 + igetbits_(&idynd, &c__7, &c__17);
}
/* Now horizontal stuff */
hoff = hoffsd;
/* Some special horizontal tweaks */
if (upstem && idno > 0 && (idno <= 4 || idno == 8 || idno == 9)) {
hoff += .4f;
}
/* User-defined tweaks */
if (bit_test(idynd2,0)) {
hoff += (igetbits_(&idynd2, &c__9, &c__1) - 256) * .1f;
}
if (numdyn > 1) {
/* Horizontal-interaction-based tweaks. */
/* Cases: */
/* numdyn type1 type2 type3 data used */
/* 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) */
/* 2 hrpnend wrd-grp - ivowg,hoh2 */
/* 2 hrpnend hrpnstrt - hoh2h1(1...2) */
/* 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 */
if (idno > 0 && idno <= 12) {
/* Word-group, may need vertical tweak to line up. */
lbot1 += comdyn_1.ivowg[idno - 1];
/* Protecting against hp start-stop on same note */
} else if ((comslur_1.fontslur && idno >= 14 || idno == 15) &&
icntdyn < numdyn) {
/* Hairpin ending, check next type */
if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[
icntdyn] - 1], &c__4, &c__12) == 13 || !
comslur_1.fontslur && (igetbits_(&comdyn_1.idyndat[
idynn[icntdyn] - 1], &c__4, &c__12) == 13 ||
igetbits_(&comdyn_1.idyndat[idynn[icntdyn] - 1], &
c__4, &c__12) == 14)) {
/* Hairpin end then hairpin start, no words, (remember dealing with end now) */
hoff += comdyn_1.hoh2h1[0];
} else {
/* Hairpin end then word-group, need idno for w-g to set hp offset */
hoff += comdyn_1.hoh2[igetbits_(&comdyn_1.idyndat[idynn[
icntdyn] - 1], &c__4, &c__12) - 1];
}
/* Protecting against hp start-stop on same note */
} else if (icntdyn > 1 && idno > 0 && (comslur_1.fontslur && idno
< 14 || ! comslur_1.fontslur && idno < 15)) {
/* Hairpin start, check prior type */
if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[
icntdyn - 2] - 1], &c__4, &c__12) >= 14 || !
comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[
idynn[icntdyn - 2] - 1], &c__4, &c__12) == 15) {
/* Hairpin end then hairpin start, (remember dealing with start now) */
hoff += comdyn_1.hoh2h1[1];
} else {
/* Hairpin start after word-group, need idno for w-g to set hp offset */
hoff += comdyn_1.hoh1[igetbits_(&comdyn_1.idyndat[idynn[
icntdyn - 2] - 1], &c__4, &c__12) - 1];
}
}
}
/* End of if-block for 2- or 3-way interactions. */
if (! comslur_1.fontslur && idno >= 13) {
hoff = (hoff + .5f) * 6.f / 2.5f;
}
/* Slur font and hairpin. Add hoff, and change from \interneote to \qn@width */
/* Position corrections all done now. Put in the level. */
if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno
== 13 || idno == 14)) {
/* Hairpin start. */
if (! comslur_1.fontslur) {
/* Postscript hairpin start...inset placeholder for start level. */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 5, a__1[1] = "{ }";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote += 5;
}
} else {
/* Insert actual level in all cases except hairpin start */
/* Create string with level in it */
if (lbot1 > 9) {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___368);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 3, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 4;
} else if (lbot1 > -1) {
*(unsigned char *)&ch__1[0] = lbot1 + 48;
s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1);
lnumpq = 1;
} else if (lbot1 > -10) {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___370);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 3, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 4;
} else {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___371);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 4, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 5;
}
/* Level has now been computed and stored in numpq */
/* Append the level */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = lnumpq, a__1[1] = numpq;
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote += lnumpq;
}
if (dabs(hoff) < .001f) {
/* No horiz offset */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = "0";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
++lnote;
} else {
/* Horizontal tweak */
lform = lfmt1_(&hoff);
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = "{";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
++lnote;
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + lform - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__6[0] = 2, a__3[0] = "(f";
i__5 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__5);
i__6[1] = 1, a__3[1] = ch__1;
i__6[2] = 3, a__3[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__3, i__6, &c__3, (ftnlen)6),
ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&hoff, (ftnlen)sizeof(real));
e_wsfi();
lnote += lform;
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
++lnote;
}
if (idno == 0) {
/* text-dynamic. Find the string and append it */
i__2 = comdyn_1.ntxtdyn;
for (jtxtdyn = jtxtdyn1; jtxtdyn <= i__2; ++jtxtdyn) {
/* ivxip = ivx+16*ip */
ivxip = *ivx + (*ip << 5);
if (ivxip == comdyn_1.ivxiptxt[jtxtdyn - 1]) {
goto L5;
}
/* L4: */
}
printl_("Abnormal stop in putdyn", (ftnlen)23);
stop1_();
L5:
ltxtdyn = lenstr_(comdyn_1.txtdynq + (jtxtdyn - 1 << 7), &c__128,
(ftnlen)128);
/* Font size based on musicsize */
if (commus_1.musize == 20) {
/* Writing concatenation */
i__7[0] = lnote, a__4[0] = notexq;
i__7[1] = 1, a__4[1] = "{";
i__7[2] = 1, a__4[2] = "\\";
i__7[3] = 7, a__4[3] = "medtype";
i__7[4] = 1, a__4[4] = "\\";
i__7[5] = 3, a__4[5] = "it ";
s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79);
lnote += 13;
} else if (commus_1.musize == 16) {
/* Writing concatenation */
i__7[0] = lnote, a__4[0] = notexq;
i__7[1] = 1, a__4[1] = "{";
i__7[2] = 1, a__4[2] = "\\";
i__7[3] = 8, a__4[3] = "normtype";
i__7[4] = 1, a__4[4] = "\\";
i__7[5] = 3, a__4[5] = "it ";
s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79);
lnote += 14;
} else if (commus_1.musize == 24) {
/* Writing concatenation */
i__7[0] = lnote, a__4[0] = notexq;
i__7[1] = 1, a__4[1] = "{";
i__7[2] = 1, a__4[2] = "\\";
i__7[3] = 7, a__4[3] = "bigtype";
i__7[4] = 1, a__4[4] = "\\";
i__7[5] = 3, a__4[5] = "it ";
s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79);
lnote += 13;
} else if (commus_1.musize == 29) {
/* Writing concatenation */
i__7[0] = lnote, a__4[0] = notexq;
i__7[1] = 1, a__4[1] = "{";
i__7[2] = 1, a__4[2] = "\\";
i__7[3] = 7, a__4[3] = "Bigtype";
i__7[4] = 1, a__4[4] = "\\";
i__7[5] = 3, a__4[5] = "it ";
s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79);
lnote += 13;
}
/* Writing concatenation */
i__6[0] = lnote, a__3[0] = notexq;
i__6[1] = ltxtdyn, a__3[1] = comdyn_1.txtdynq + (jtxtdyn - 1 << 7)
;
i__6[2] = 1, a__3[2] = "}";
s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79);
lnote = lnote + ltxtdyn + 1;
/* Reset jtxtdyn1 just in case >1 txtdyn on same note. */
jtxtdyn1 = jtxtdyn + 1;
} else if (idno <= 12) {
/* Letter-group dynamic. Append the letter-group command */
id = idno << 2;
i__2 = id - 4;
s_copy(dynstrq, dyntablq + i__2, (ftnlen)4, id - i__2);
id = lenstr_(dynstrq, &c__4, (ftnlen)4);
/* Writing concatenation */
i__6[0] = lnote, a__3[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__6[1] = 1, a__3[1] = ch__1;
i__6[2] = id, a__3[2] = dynstrq;
s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79);
lnote = lnote + 1 + id;
}
addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80);
if (! comslur_1.fontslur && idno == 15) {
/* PS slurs on, hairpin is ending. Go back and set height at beginning. */
/* Add user-defined tweak to default level */
lbot1 = lpretweak + comdyn_1.levhssav[*ivx - 1];
if (lbot1 > 9) {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___378);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 3, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 4;
} else if (lbot1 > -1) {
*(unsigned char *)&ch__1[0] = lbot1 + 48;
s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1);
lnumpq = 1;
} else if (lbot1 > -10) {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___379);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 3, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 4;
} else {
s_copy(numpq, "{", (ftnlen)5, (ftnlen)1);
s_wsfi(&io___380);
do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 4, a__1[0] = numpq;
i__3[1] = 1, a__1[1] = "}";
s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5);
lnumpq = 5;
}
/* Construct string to search backwards for placeholder */
if (*ivx <= 9) {
/* Writing concatenation */
i__6[0] = 5, a__3[0] = "cresc";
*(unsigned char *)&ch__1[0] = *ivx + 48;
i__6[1] = 1, a__3[1] = ch__1;
i__6[2] = 5, a__3[2] = "{ }";
s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48);
ltemp = 11;
} else if (*ivx <= 19) {
/* Writing concatenation */
i__6[0] = 7, a__3[0] = "cresc{1";
*(unsigned char *)&ch__1[0] = *ivx + 38;
i__6[1] = 1, a__3[1] = ch__1;
i__6[2] = 6, a__3[2] = "}{ }";
s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48);
ltemp = 14;
} else {
/* Writing concatenation */
i__6[0] = 7, a__3[0] = "cresc{2";
*(unsigned char *)&ch__1[0] = *ivx + 28;
i__6[1] = 1, a__3[1] = ch__1;
i__6[2] = 6, a__3[2] = "}{ }";
s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48);
ltemp = 14;
}
s_wsfe(&io___383);
/* Writing concatenation */
i__3[0] = *lsout, a__1[0] = soutq;
i__3[1] = 1, a__1[1] = "%";
s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)81);
do_fio(&c__1, ch__3, *lsout + 1);
e_wsfe();
*lsout = 0;
/* Writing concatenation */
i__3[0] = ltemp - 5, a__1[0] = tempq;
i__3[1] = lnumpq, a__1[1] = numpq;
s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)53);
i__2 = ltemp - 5 + lnumpq;
backfill_(&c__11, tempq, <emp, ch__4, &i__2, (ftnlen)48, ltemp
- 5 + lnumpq);
}
/* L3: */
}
/* Shrink arrays, decrease ndyn 111109 */
for (icntdyn = numdyn; icntdyn >= 1; --icntdyn) {
i__1 = comdyn_1.ndyn - 1;
for (jdyn = idynn[icntdyn - 1]; jdyn <= i__1; ++jdyn) {
comdyn_1.idyndat[jdyn - 1] = comdyn_1.idyndat[jdyn];
comdyn_1.idynda2[jdyn - 1] = comdyn_1.idynda2[jdyn];
/* L7: */
}
--comdyn_1.ndyn;
/* L6: */
}
return 0;
} /* dodyn_ */
/* Subroutine */ int dograce_(integer *ivx, integer *ip, real *ptgr, char *
soutq, integer *lsout, integer *ncm, integer *nacc, integer *ig,
integer *ipl, logical *farend, logical *beamon, integer *nolev,
integer *ncmidx, integer *islur, integer *nvmx, integer *nv, integer *
ibmcnt, real *tnote, char *ulq, integer *instno, ftnlen soutq_len,
ftnlen ulq_len)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2[2], i__3[3], i__4[4], i__5, i__6;
real r__1;
char ch__1[1], ch__2[6], ch__3[2], ch__4[5], ch__5[11], ch__6[7], ch__7[4]
, ch__8[87], ch__9[15], ch__10[16], ch__11[9], ch__12[12], ch__13[
21], ch__14[20], ch__15[19], ch__16[24], ch__17[13], ch__18[82],
ch__19[3], ch__20[10];
icilist ici__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer i_nint(real *), s_wsfi(icilist *), e_wsfi(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_sign(integer *, integer *);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static integer lnotenga;
extern integer igetbits_(integer *, integer *, integer *);
static integer i__;
static real x, y, em;
static integer mg;
static char sq[1];
static real finalshift;
static integer ing, ngs;
extern integer log2_(integer *);
static integer lacc;
static real beta;
extern /* Character */ VOID chax_(char *, ftnlen, integer *), udqq_(char *
, ftnlen, integer *, integer *, integer *, integer *, integer *,
integer *);
static real sumx, sumy;
extern /* Subroutine */ int stop1_(void);
static real delta, ptoff;
static integer lnote;
static char noteq[8];
static real sumxx, sumxy, sumyy;
static integer nolev1;
static logical isgaft;
extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen),
addstr_(char *, integer *, char *, integer *, ftnlen, ftnlen);
static integer islope;
static logical iswaft;
static char acsymq[3];
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten, itrans, niptgr;
static logical stemup, normsp;
static char notexq[79], noteqga[8];
static real wheadpt1;
/* Fortran I/O blocks */
static cilist io___389 = { 0, 6, 0, 0, 0 };
static cilist io___393 = { 0, 6, 0, 0, 0 };
static cilist io___394 = { 0, 6, 0, 0, 0 };
static cilist io___395 = { 0, 15, 0, "(/,a)", 0 };
static icilist io___398 = { 0, notexq, 0, "(i2)", 2, 1 };
static cilist io___399 = { 0, 6, 0, 0, 0 };
static icilist io___423 = { 0, notexq+13, 0, "(a1,f4.1)", 5, 1 };
static icilist io___425 = { 0, notexq+13, 0, "(f4.1)", 4, 1 };
static icilist io___427 = { 0, notexq+5, 0, "(f3.1)", 3, 1 };
/* ip will be one LESS than current note, for way-after's before bar-end, */
/* It is only used to find ig. */
/* ig is returned to makeabar in case there's a slur that needs to be ended */
/* Parameter adjustments */
ulq -= 25;
--ptgr;
/* Function Body */
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
isgaft = bit_test(*ipl,29);
iswaft = bit_test(*ipl,31);
normsp = ! isgaft;
/* Find ig. */
i__1 = comgrace_1.ngrace;
for (*ig = 1; *ig <= i__1; ++(*ig)) {
if (comgrace_1.ipg[*ig - 1] == *ip && comgrace_1.ivg[*ig - 1] == *ivx)
{
goto L121;
}
/* L120: */
}
s_wsle(&io___389);
do_lio(&c__9, &c__1, "Problem finding grace index in dograce", (ftnlen)38)
;
e_wsle();
s_stop("", (ftnlen)0);
L121:
ngs = comgrace_1.ngstrt[*ig - 1];
mg = comgrace_1.multg[*ig - 1];
/* wheadpt1 = wheadpt*fullsize(ivx) */
wheadpt1 = comask_1.wheadpt * comfig_1.fullsize[*instno - 1];
/* For way-after-graces at end of bar, must set the octave. */
if (*farend) {
comoct_1.noctup = 0;
if (*ncm == 23) {
comoct_1.noctup = -2;
}
}
if (comgrace_1.slurg[*ig - 1] && ! iswaft && ! isgaft) {
if (comslur_1.listslur == 16777215) {
s_wsle(&io___393);
e_wsle();
s_wsle(&io___394);
do_lio(&c__9, &c__1, "You defined the twentyfifth slur, one too "
"many!", (ftnlen)47);
e_wsle();
s_wsfe(&io___395);
do_fio(&c__1, "You defined the twentyfifth slur, one too many!", (
ftnlen)47);
e_wsfe();
stop1_();
}
/* Slur on fore-grace. Get index of next slur not in use, from 23 down. */
i__1 = 16777215 - comslur_1.listslur;
comslur_1.ndxslur = log2_(&i__1);
}
if (comgrace_1.nng[*ig - 1] == 1) {
/* Single grace. */
if (normsp) {
/* Anything but GA */
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 5, a__1[1] = "shlft";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6);
addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80);
niptgr = i_nint(&ptgr[*ig]);
/* Empirical tweak for postscript. */
/* if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) */
/* ++ */
if (niptgr < 10) {
/* Writing concatenation */
i__1 = niptgr + 48;
chax_(ch__1, (ftnlen)1, &i__1);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 1, a__1[1] = "{";
s_cat(ch__3, a__1, i__2, &c__2, (ftnlen)2);
addstr_(ch__3, &c__2, soutq, lsout, (ftnlen)2, (ftnlen)80);
} else if (niptgr < 100) {
s_wsfi(&io___398);
do_fio(&c__1, (char *)&niptgr, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 1, a__2[0] = "{";
i__3[1] = 2, a__2[1] = notexq;
i__3[2] = 2, a__2[2] = "}{";
s_cat(ch__4, a__2, i__3, &c__3, (ftnlen)5);
addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80);
} else {
s_wsle(&io___399);
do_lio(&c__9, &c__1, "Call Dr. Don if you really want grace "
"note group > 99 pt", (ftnlen)56);
e_wsle();
s_stop("", (ftnlen)0);
}
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 10, a__1[1] = "gaft{1.5}{";
s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11);
addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80);
/* GA. Compute aftshft, for later use. */
comgrace_1.aftshft = spfacs_1.grafac;
if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) {
comgrace_1.aftshft += spfacs_1.agc1fac;
}
comgrace_1.aftshft *= comask_1.wheadpt;
}
if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) {
/* Start slur on pre-grace. No accounting needed since will be ended very soon. */
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)
8);
if (comslur_1.fontslur) {
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 6, a__1[1] = "islurd";
s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7);
addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80)
;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 6, a__1[1] = "isluru";
s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7);
addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80)
;
}
} else {
/* Start Postscript slur. */
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 3, a__1[1] = "isd";
s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4);
addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80)
;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 3, a__1[1] = "isu";
s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4);
addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80)
;
}
}
/* Print slur number, 23-ndxslur */
lnote = 0;
if (23 - comslur_1.ndxslur < 10) {
/* notexq = notexq(1:lnote)//chax(59-ndxslur) */
i__1 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1);
lnote = 1;
} else if (23 - comslur_1.ndxslur < 20) {
/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */
/* Writing concatenation */
i__3[0] = 2, a__2[0] = "{1";
i__1 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 1, a__2[2] = "}";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
lnote = 4;
} else {
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
i__4[1] = 2, a__3[1] = "{2";
i__1 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[2] = 1, a__3[2] = ch__1;
i__4[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
lnote = 4;
}
/* if (11-ndxslur .lt. 10) then */
/* call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, */
/* * soutq,lsout) */
/* else */
/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */
/* * 4+lnoten,soutq,lsout) */
/* end if */
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = lnoten, a__1[1] = noteq;
s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87);
i__1 = lnote + lnoten;
addstr_(ch__8, &i__1, soutq, lsout, lnote + lnoten, (ftnlen)80);
if (! comslur_1.fontslur) {
/* Horizontal tweaks for postscript slur on single grace */
stemup = TRUE_;
if (comgrace_1.upg[*ig - 1]) {
/* Check for up-grace + down stem. Get stem direction */
if (! (*beamon)) {
/* Separate note. Get stem direction. */
udqq_(ch__1, (ftnlen)1, nolev, ncmidx, islur, nvmx,
ivx, nv);
stemup = *(unsigned char *)&ch__1[0] == 'u';
} else {
/* In a beam */
stemup = *(unsigned char *)&ulq[*ivx + *ibmcnt * 24]
== 'u';
}
/* Stop the shift if whole note */
stemup = stemup || *tnote > 63.f;
}
if (stemup) {
addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen)
80);
} else {
addstr_("{-.8}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen)
80);
}
}
}
if (comgrace_1.naccg[ngs - 1] > 0) {
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)
8);
/* Save for checking octave shifts in GA */
if (isgaft) {
lnotenga = lnoten;
s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8);
}
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3);
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 3, a__3[1] = "big";
i__4[2] = lacc, a__3[2] = acsymq;
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15);
i__1 = lacc + 4 + lnoten;
addstr_(ch__9, &i__1, soutq, lsout, lacc + 4 + lnoten, (ftnlen)80)
;
}
if (comgrace_1.slashg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 3, a__1[1] = "grc";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
lnote = 4;
} else if (mg == 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 2, a__1[1] = "zq";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
lnote = 3;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 2, a__1[1] = "zc";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
i__1 = mg;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Writing concatenation */
i__2[0] = i__ + 1, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "c";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
/* L61: */
}
lnote = mg + 2;
}
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "u";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "l";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
}
i__1 = lnote + 1;
addstr_(notexq, &i__1, soutq, lsout, (ftnlen)79, (ftnlen)80);
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8);
if (isgaft && comgrace_1.naccg[ngs - 1] == 0) {
lnotenga = lnoten;
s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8);
}
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
addstr_(noteq, &lnoten, soutq, lsout, (ftnlen)8, (ftnlen)80);
if (comgrace_1.slashg[*ig - 1]) {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 5, a__3[1] = "off{-";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 9, a__3[3] = "noteskip}";
s_cat(ch__10, a__3, i__4, &c__4, (ftnlen)16);
addstr_(ch__10, &c__16, soutq, lsout, (ftnlen)16, (ftnlen)80);
}
/* Above code needed since slashg causes spacing */
if (comgrace_1.slurg[*ig - 1] && (iswaft || isgaft)) {
/* Terminate slur on single after-grace */
/* ndxslur = igetbits(ipl,4,23) */
comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23);
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)
8);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 5, a__1[1] = "tslur";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6);
addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80);
/* c Print 11-ndxslur */
/* Print 24-ndxslur */
/* if (11-ndxslur .lt. 10) then */
if (23 - comslur_1.ndxslur < 10) {
/* call addstr(chax(59-ndxslur)//noteq(1:lnoten), */
/* Writing concatenation */
i__1 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = lnoten, a__1[1] = noteq;
s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9);
i__5 = lnoten + 1;
addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80);
} else if (23 - comslur_1.ndxslur < 20) {
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{2";
i__1 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__5 = lnoten + 4;
addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80);
} else {
/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{1";
i__1 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__5 = lnoten + 4;
addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80);
}
comgrace_1.slurg[*ig - 1] = FALSE_;
comslur_1.listslur = bit_clear(comslur_1.listslur,
comslur_1.ndxslur);
}
addstr_("}", &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80);
/* +++ Try to fix loss of octave with single gaft */
/* if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', */
/* * 13+lnoten,soutq,lsout) */
if (isgaft) {
itrans = 0;
i__1 = lnotenga;
for (i__ = 1; i__ <= i__1; ++i__) {
chax_(ch__1, (ftnlen)1, &c__39);
if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned char *)&
ch__1[0]) {
itrans += 7;
} else /* if(complicated condition) */ {
chax_(ch__1, (ftnlen)1, &c__96);
if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned
char *)&ch__1[0]) {
itrans += -7;
}
}
/* L1: */
}
if (itrans == -14) {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 7, a__3[1] = "advance";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 12, a__3[3] = "transpose-14";
s_cat(ch__13, a__3, i__4, &c__4, (ftnlen)21);
addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80);
} else if (itrans == -7) {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 7, a__3[1] = "advance";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 11, a__3[3] = "transpose-7";
s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20);
addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80);
} else if (itrans == 7) {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 7, a__3[1] = "advance";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 10, a__3[3] = "transpose7";
s_cat(ch__15, a__3, i__4, &c__4, (ftnlen)19);
addstr_(ch__15, &c__19, soutq, lsout, (ftnlen)19, (ftnlen)80);
} else if (itrans == 14) {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 7, a__3[1] = "advance";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 11, a__3[3] = "transpose14";
s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20);
addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80);
}
}
} else {
/* Multiple grace. Put in literally. Compute beam stuff */
sumx = 0.f;
sumy = 0.f;
sumxy = 0.f;
sumxx = 0.f;
sumyy = 0.f;
x = 0.f;
i__1 = ngs + comgrace_1.nng[*ig - 1] - 1;
for (ing = ngs; ing <= i__1; ++ing) {
if (ing > ngs && comgrace_1.naccg[ing - 1] > 0) {
x += spfacs_1.acgfac;
}
y = (real) comgrace_1.nolevg[ing - 1];
sumx += x;
sumy += y;
sumxy += x * y;
sumxx += x * x;
sumyy += y * y;
x += spfacs_1.emgfac;
/* L118: */
}
delta = comgrace_1.nng[*ig - 1] * sumxx - sumx * sumx;
em = (comgrace_1.nng[*ig - 1] * sumxy - sumx * sumy) / delta;
r__1 = em * .5f * spfacs_1.gslfac;
islope = i_nint(&r__1);
if (abs(islope) > 9) {
islope = i_sign(&c__9, &islope);
}
beta = (sumy - islope / spfacs_1.gslfac * sumx) / comgrace_1.nng[*ig
- 1];
nolev1 = i_nint(&beta);
/* Back up */
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 7, a__3[1] = "settiny";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 4, a__3[3] = "off{";
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
if (normsp) {
s_wsfi(&io___423);
do_fio(&c__1, "-", (ftnlen)1);
do_fio(&c__1, (char *)&ptgr[*ig], (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__2[0] = 18, a__1[0] = notexq;
i__2[1] = 3, a__1[1] = "pt}";
s_cat(ch__13, a__1, i__2, &c__2, (ftnlen)21);
addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80);
finalshift = ptgr[*ig];
} else {
comgrace_1.aftshft = comask_1.wheadpt * 1.33f;
if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) {
comgrace_1.aftshft += comask_1.wheadpt * .5f;
}
s_wsfi(&io___425);
do_fio(&c__1, (char *)&comgrace_1.aftshft, (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__4[0] = 17, a__3[0] = notexq;
i__4[1] = 3, a__3[1] = "pt}";
i__4[2] = 1, a__3[2] = sq;
i__4[3] = 3, a__3[3] = "bsk";
s_cat(ch__16, a__3, i__4, &c__4, (ftnlen)24);
addstr_(ch__16, &c__24, soutq, lsout, (ftnlen)24, (ftnlen)80);
}
/* Start the beam */
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 2, a__1[1] = "ib";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
i__1 = mg;
for (ing = 2; ing <= i__1; ++ing) {
/* Writing concatenation */
i__2[0] = ing + 1, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "b";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
/* L119: */
}
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = mg + 2, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "u";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__2[0] = mg + 2, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "l";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
}
/* Writing concatenation */
i__2[0] = mg + 3, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "0";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
/* Get starting note for beam */
notefq_(noteq, &lnoten, &nolev1, ncm, (ftnlen)8);
/* Writing concatenation */
i__2[0] = mg + 4, a__1[0] = notexq;
i__2[1] = lnoten, a__1[1] = noteq;
s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87);
i__1 = mg + 4 + lnoten;
addstr_(ch__8, &i__1, soutq, lsout, mg + 4 + lnoten, (ftnlen)80);
/* Put in the slope */
if (islope >= 0) {
i__1 = islope + 48;
chax_(ch__1, (ftnlen)1, &i__1);
addstr_(ch__1, &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80);
} else {
/* Writing concatenation */
i__3[0] = 2, a__2[0] = "{-";
i__1 = 48 - islope;
chax_(ch__1, (ftnlen)1, &i__1);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 1, a__2[2] = "}";
s_cat(ch__7, a__2, i__3, &c__3, (ftnlen)4);
addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80);
}
/* Start a slur on multiple fore-grace */
if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) {
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)
8);
if (comslur_1.fontslur) {
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 6, a__1[1] = "islurd";
s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7);
addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80)
;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 6, a__1[1] = "isluru";
s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7);
addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80)
;
}
} else {
/* Need a tweak for postscript slur */
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 3, a__1[1] = "isd";
s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4);
addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80)
;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 3, a__1[1] = "isu";
s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4);
addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80)
;
}
}
/* Print 11-ndxslur */
if (23 - comslur_1.ndxslur < 10) {
/* Writing concatenation */
i__1 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = lnoten, a__1[1] = noteq;
s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9);
i__5 = lnoten + 1;
addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80);
} else if (23 - comslur_1.ndxslur < 2) {
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{1";
i__1 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__5 = lnoten + 4;
addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80);
} else {
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{1";
i__1 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__5 = lnoten + 4;
addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80);
}
/* Put in tweak for postscript slur */
if (! comslur_1.fontslur) {
addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80);
}
}
/* Put in first note. Call notefq again in case octave changed */
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8);
if (comgrace_1.naccg[ngs - 1] == 0) {
/* Writing concatenation */
i__3[0] = 1, a__2[0] = sq;
i__3[1] = 4, a__2[1] = "zqb0";
i__3[2] = lnoten, a__2[2] = noteq;
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
lnote = lnoten + 5;
} else {
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3);
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 3, a__3[1] = "big";
i__4[2] = lacc, a__3[2] = acsymq;
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
lnote = lacc + 4 + lnoten;
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)
8);
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
i__4[1] = 1, a__3[1] = sq;
i__4[2] = 4, a__3[2] = "zqb0";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
lnote = lnote + 5 + lnoten;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
i__1 = ngs + comgrace_1.nng[*ig - 1] - 1;
for (ing = ngs + 1; ing <= i__1; ++ing) {
/* Skip */
ptoff = wheadpt1 * spfacs_1.emgfac;
if (comgrace_1.naccg[ing - 1] > 0) {
ptoff += wheadpt1 * spfacs_1.acgfac;
}
if (isgaft && ! iswaft) {
comgrace_1.aftshft += ptoff;
}
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 4, a__1[1] = "off{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
s_wsfi(&io___427);
do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real));
e_wsfi();
if (normsp) {
finalshift -= ptoff;
}
/* Writing concatenation */
i__2[0] = 8, a__1[0] = notexq;
i__2[1] = 3, a__1[1] = "pt}";
s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11);
addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80);
if (ing == ngs + comgrace_1.nng[*ig - 1] - 1) {
/* Terminate beam if needed */
if (comgrace_1.upg[*ig - 1]) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 4, a__1[1] = "tbu0";
s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5);
addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80)
;
} else {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 4, a__1[1] = "tbl0";
s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5);
addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80)
;
}
/* Terminate after slur if needed */
if ((isgaft || iswaft) && comgrace_1.slurg[*ig - 1]) {
/* if (iswaft) ndxslur = igetbits(ipl,4,23) */
if (iswaft) {
comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23);
}
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm,
(ftnlen)8);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 5, a__1[1] = "tslur";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6);
addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80)
;
/* Print 11-ndxslur */
/* c Print 23-ndxslur */
if (23 - comslur_1.ndxslur < 10) {
/* Writing concatenation */
i__5 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__5);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = lnoten, a__1[1] = noteq;
s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9);
i__6 = lnoten + 1;
addstr_(ch__11, &i__6, soutq, lsout, lnoten + 1, (
ftnlen)80);
} else if (23 - comslur_1.ndxslur < 20) {
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{2";
i__5 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__5);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__6 = lnoten + 4;
addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, (
ftnlen)80);
} else {
/* Writing concatenation */
i__4[0] = 2, a__3[0] = "{1";
i__5 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__5);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 1, a__3[2] = "}";
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12);
i__6 = lnoten + 4;
addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, (
ftnlen)80);
}
/* Stop slur terminator after exit from this subroutine */
comslur_1.listslur = bit_clear(comslur_1.listslur,
comslur_1.ndxslur);
comgrace_1.slurg[*ig - 1] = FALSE_;
}
}
/* Accidental if needed */
if (comgrace_1.naccg[ing - 1] > 0) {
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, (
ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
accsym_(&comgrace_1.naccg[ing - 1], acsymq, &lacc, (ftnlen)3);
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 3, a__3[1] = "big";
i__4[2] = lacc, a__3[2] = acsymq;
i__4[3] = lnoten, a__3[3] = noteq;
s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15);
i__5 = lacc + 4 + lnoten;
addstr_(ch__9, &i__5, soutq, lsout, lacc + 4 + lnoten, (
ftnlen)80);
}
/* Put in the (beamed) grace note */
notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, (ftnlen)
8);
/* Writing concatenation */
i__3[0] = 1, a__2[0] = sq;
i__3[1] = 4, a__2[1] = "zqb0";
i__3[2] = lnoten, a__2[2] = noteq;
s_cat(ch__17, a__2, i__3, &c__3, (ftnlen)13);
i__5 = lnoten + 5;
addstr_(ch__17, &i__5, soutq, lsout, lnoten + 5, (ftnlen)80);
/* L127: */
}
/* Terminate the grace */
/* notexq = sq//'normalnotesize'//sq//'off{' */
/* lnote = 20 */
/* notexq = '}'//sq//'off{' */
/* lnote = 6 */
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 4, a__1[1] = "off{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
lnote = 5;
ptoff = comask_1.wheadpt * spfacs_1.emgfac;
if ((*nacc & 3) > 0 && ! bit_test(*nacc,17)) {
ptoff += comask_1.wheadpt * spfacs_1.accfac;
}
if (isgaft && ! iswaft) {
/* Writing concatenation */
i__2[0] = 5, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "-";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
lnote = 6;
ptoff = comgrace_1.aftshft;
}
if (normsp) {
ptoff = finalshift;
}
if (ptoff < 9.95f) {
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f3.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real));
e_wsfi();
lnote += 3;
} else if (ptoff < 99.95f) {
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f4.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real));
e_wsfi();
lnote += 4;
} else {
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 5 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f5.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real));
e_wsfi();
lnote += 5;
}
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 3, a__1[1] = "pt}";
s_cat(ch__18, a__1, i__2, &c__2, (ftnlen)82);
i__1 = lnote + 3;
addstr_(ch__18, &i__1, soutq, lsout, lnote + 3, (ftnlen)80);
if (isgaft && ! iswaft) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 2, a__1[1] = "sk";
s_cat(ch__19, a__1, i__2, &c__2, (ftnlen)3);
addstr_(ch__19, &c__3, soutq, lsout, (ftnlen)3, (ftnlen)80);
}
/* Writing concatenation */
i__2[0] = 1, a__1[0] = sq;
i__2[1] = 9, a__1[1] = "resetsize";
s_cat(ch__20, a__1, i__2, &c__2, (ftnlen)10);
addstr_(ch__20, &c__10, soutq, lsout, (ftnlen)10, (ftnlen)80);
}
return 0;
} /* dograce_ */
/* Subroutine */ int dopsslur_(integer *nolev, integer *isdat1, integer *
isdat2, integer *isdat3, integer *isdat4, integer *nsdat, integer *ip,
integer *iv, integer *kv, integer *nv, logical *beamon, integer *ncm,
char *soutq, integer *lsout, char *ulq, integer *islur, integer *ipl,
integer *iornq, integer *islhgt, real *tno, integer *nacc, ftnlen
soutq_len, ftnlen ulq_len)
{
/* System generated locals */
address a__1[3], a__2[4], a__3[2];
integer i__1, i__2, i__3[3], i__4[4], i__5[2], i__6;
char ch__1[1], ch__2[1], ch__3[6], ch__4[9];
icilist ici__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer ivoffinc;
extern integer igetbits_(integer *, integer *, integer *);
static integer j, icm;
extern integer log2_(integer *);
static integer imid;
extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char *
, ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *,
integer *, integer *, integer *, integer *, integer *);
extern integer lfmt1_(real *);
extern /* Subroutine */ int stop1_(void);
static integer ihoff;
static logical iscrd;
static integer isdat, ivoff;
static real shift;
static integer iupdn, lform, lnote;
static logical pstie;
static char noteq[8];
static integer idcode, isdata;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static logical settie;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten, nolevs;
static logical stemup;
static char notexq[79];
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
static integer numdrop;
static char slurudq[1];
/* Fortran I/O blocks */
static cilist io___441 = { 0, 6, 0, 0, 0 };
static cilist io___442 = { 0, 6, 0, 0, 0 };
static cilist io___443 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___451 = { 0, 6, 0, 0, 0 };
/* Called once per main note. */
/* 12 May 2002 Create this subroutine to isolate postscript slurs/ties. */
/* Always set \Nosluradjust\Notieadjust */
/* 130316 */
/* Bits in isdat1: */
/* 13-17 iv */
/* 3-10 ip */
/* 11 start/stop switch */
/* 12 kv-1 */
/* 19-25 ichar(code$) */
/* 26 force direction? */
/* 27 forced dir'n = up if on, set in sslur; also */
/* final direction, set in doslur when beam is started, used on term. */
/* 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. */
/* 18 int(ndxslur/16), ditto. So this allows ndxslur>15. */
/* Bits in isdat2 */
/* 0 Chord switch. Not set on main note. */
/* 1-2 left/right notehead shift. Set only for chord note. */
/* 3 tie positioning */
/* 4 dotted flag */
/* 6-11 voff1 1-63 => -31...+31 */
/* 12-18 hoff1 1-127 => -6.3...+6.3 */
/* 19-25 nolev */
/* 26 \sluradjust (p+s) */
/* 27 \nosluradjust (p-s) */
/* 28 \tieadjust (p+t) */
/* 29 \notieadjust (p-t) */
/* Bits in isdat3: Only used for slur endings */
/* 0 set if midslur (at least one argument) */
/* 1 set if curve (2 more args) */
/* 2-7 32+first arg (height correction) (1st arg may be negative) */
/* 8-10 second arg (initial slope) */
/* 11-13 third arg (closing slope) */
/* 14-21 tie level for use in LineBreakTies */
/* 22-29 ncm for use in LineBreakTies */
/* Bits in isdat4 Only used for linebreak slurs */
/* 0-5 Linebreak seg 1 voff 1-63 => -31...+31 */
/* 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 */
/* 16-21 Linebreak seg 2 voff 1-63 => -31...+31 */
/* 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 */
/* In listslur bit ib is on if slur index ib is in use, ib=0-13. */
/* ndxslur = slur index */
/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */
/* s-slur is blank (idcode=32), t-slur is idcode=1. */
/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */
/* Ivoff will be set for ./_ only if no user-defined shift is specified. */
/* If highest note has upslur, save slur height in islhgt in case */
/* ornament must be moved. */
/* Parameter adjustments */
--isdat4;
--isdat3;
--isdat2;
--isdat1;
/* Function Body */
*islhgt = 0;
if (*beamon) {
stemup = *(unsigned char *)ulq == 'u';
} else if (commvl_1.nvmx[*iv - 1] == 2) {
if (! bit_test(*islur,30)) {
/* Single note, 2 lines of music, stem direction not forced */
stemup = commvl_1.ivx > *nv;
} else {
stemup = bit_test(*islur,17);
}
} else {
udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], &
commvl_1.ivx, nv);
stemup = *(unsigned char *)&ch__1[0] == 'u';
}
iscrd = bit_test(*ipl,10);
if (commidi_1.ismidi) {
settie = FALSE_;
comslm_1.dbltie = FALSE_;
}
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
isdata = isdat1[isdat];
if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(&
isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, &
c__12) + 1) {
/* Since iv and kv match, ivx will be correct */
idcode = igetbits_(&isdata, &c__7, &c__19);
ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32;
ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64;
iupdn = 0;
*(unsigned char *)slurudq = 'd';
nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19);
pstie = bit_test(isdat2[isdat],3) || idcode == 1;
if (bit_test(isdata,11)) {
/* Turnon */
/* if (nolevs.eq.0 .or. nolevs.gt.60) then */
/* c */
/* c Note was a rest, cannot start slur on rest. */
/* c */
/* print* */
/* call printl('Cannot start slur on a rest') */
/* call stop1() */
/* nolevs = ncm+5 */
/* end if */
/* Get slur direction */
if (bit_test(isdata,26)) {
/* Force slur direction */
if (bit_test(isdata,27)) {
*(unsigned char *)slurudq = 'u';
}
} else if (commvl_1.nvmx[*iv - 1] == 1) {
/* Only one voice per line */
if (! (*beamon)) {
/* Separate note. */
udfq_(ch__1, (ftnlen)1, nolev, ncm);
*(unsigned char *)slurudq = *(unsigned char *)&ch__1[
0];
} else {
/* In a beam */
if (*(unsigned char *)ulq != 'u') {
*(unsigned char *)slurudq = 'u';
}
}
if (iscrd) {
if (nolevs > *ncm) {
*(unsigned char *)slurudq = 'u';
} else {
*(unsigned char *)slurudq = 'd';
}
}
} else {
/* Two voices per line. Get default */
if (commvl_1.ivx > *nv) {
*(unsigned char *)slurudq = 'u';
}
/* Upper voice of the two, so up slur */
}
/* Set level for slur starting on rest */
if (nolevs == 0 || nolevs > 60) {
if (*(unsigned char *)slurudq == 'u') {
nolevs = *ncm + 2;
} else {
nolevs = *ncm - 2;
}
}
/* Save up/down-ness for use at termination */
if (*(unsigned char *)slurudq == 'u') {
isdata = bit_set(isdata,27);
}
/* End of section for setting slur direction, still in "Turnon" if-block. */
if (bit_test(*iornq,11) || bit_test(*iornq,12)) {
/* Raise or lower slur by one unit provided . or _ is on same side as slur */
ivoffinc = 0;
if (stemup && *(unsigned char *)slurudq == 'd' || !
stemup && *(unsigned char *)slurudq == 'u') {
/* Must move the slur for _ or . */
if (stemup) {
ivoffinc = -1;
} else {
ivoffinc = 1;
}
if ((stemup && *nolev >= *ncm - 2 || ! stemup && *
nolev <= *ncm + 2) && (i__2 = *ncm - *nolev,
abs(i__2)) % 2 == 0) {
ivoffinc <<= 1;
}
ivoff += ivoffinc;
}
}
if (comslur_1.listslur == 16777215) {
s_wsle(&io___441);
e_wsle();
s_wsle(&io___442);
do_lio(&c__9, &c__1, "You1 defined the twentyfifth slur,"
" one too many!", (ftnlen)48);
e_wsle();
s_wsfe(&io___443);
do_fio(&c__1, "You defined the twentyfifth slur, one too"
" many!", (ftnlen)47);
e_wsfe();
stop1_();
}
/* Get index of next slur not in use, starting from 12 down */
i__2 = 16777215 - comslur_1.listslur;
comslur_1.ndxslur = log2_(&i__2);
/* write(*,'()') */
/* write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur */
/* Record slur index */
comslur_1.listslur = bit_set(comslur_1.listslur,
comslur_1.ndxslur);
/* write(*,'(10x,B24)')listslur */
/* Save for use on termination */
/* call setbits(isdata,4,28,ndxslur) */
/* 080531 Allow >16 slurs */
i__2 = comslur_1.ndxslur % 16;
setbits_(&isdata, &c__4, &c__28, &i__2);
i__2 = comslur_1.ndxslur / 16;
setbits_(&isdata, &c__1, &c__18, &i__2);
/* Shift for stem? */
if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f)
{
if (! pstie) {
ihoff += 8;
} else {
ihoff += 2;
}
}
if (iscrd) {
/* Additional horiz shifts for h-shifted noteheads? */
if (bit_test(isdat2[isdat],1)) {
/* Slur start on left-shifted chord notehead. ASSUME downstem. */
if (nolevs == comtrill_1.minlev && *(unsigned char *)
slurudq == 'd') {
ihoff += -2;
} else {
ihoff += -10;
}
} else if (bit_test(isdat2[isdat],2)) {
/* Right shifted chord notehead. ASSUME upstem. */
if (nolevs == comtrill_1.maxlev && *(unsigned char *)
slurudq == 'u') {
ihoff += 2;
} else {
ihoff += 10;
}
}
}
chax_(ch__1, (ftnlen)1, &c__92);
s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1);
lnote = 1;
/* Check for local adjustment default changes */
if (bit_test(isdat2[isdat],26)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 10, a__1[1] = "sluradjust";
chax_(ch__2, (ftnlen)1, &c__92);
i__3[2] = 1, a__1[2] = ch__2;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 12;
} else if (bit_test(isdat2[isdat],27)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 12, a__1[1] = "nosluradjust";
chax_(ch__2, (ftnlen)1, &c__92);
i__3[2] = 1, a__1[2] = ch__2;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 14;
} else if (bit_test(isdat2[isdat],28)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 9, a__1[1] = "tieadjust";
chax_(ch__2, (ftnlen)1, &c__92);
i__3[2] = 1, a__1[2] = ch__2;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 11;
} else if (bit_test(isdat2[isdat],29)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 11, a__1[1] = "notieadjust";
chax_(ch__2, (ftnlen)1, &c__92);
i__3[2] = 1, a__1[2] = ch__2;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 13;
}
if (ihoff == 0) {
/* Write stuff for non-shifted start */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 5, a__1[1] = "islur";
i__3[2] = 1, a__1[2] = slurudq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote += 6;
} else {
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 2, a__1[1] = "is";
i__3[2] = 1, a__1[2] = slurudq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote += 3;
}
/* Prepend postscript tie switch */
if (pstie) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__4[0] = 1, a__2[0] = ch__1;
i__4[1] = 8, a__2[1] = "tieforis";
i__4[2] = 1, a__2[2] = slurudq;
i__4[3] = lnote, a__2[3] = notexq;
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 10;
}
if (bit_test(isdat2[isdat],4)) {
/* Dotted slur */
/* noteq = notexq */
/* notexq = chax(92)//'dotted'//noteq */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "dotted";
i__3[2] = lnote, a__1[2] = notexq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote += 7;
}
/* Add slur index to string */
/* c Print 11-ndxslur */
/* Print 23-ndxslur */
/* if (11-ndxslur .lt. 10) then */
if (23 - comslur_1.ndxslur < 10) {
/* 5/25/08 Allow 24 slurs */
/* notexq = notexq(1:lnote)//chax(59-ndxslur) */
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__2 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__1;
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
} else if (23 - comslur_1.ndxslur < 20) {
/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{1";
i__2 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{2";
i__2 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
}
/* Add note name to string */
/* call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) */
*islhgt = nolevs + iupdn + ivoff;
notefq_(noteq, &lnoten, islhgt, ncm, (ftnlen)8);
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = lnoten, a__3[1] = noteq;
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
lnote += lnoten;
/* Store height and staff mid level for use with LineBreakTies */
setbits_(&isdat3[isdat], &c__8, &c__14, islhgt);
setbits_(&isdat3[isdat], &c__8, &c__22, ncm);
/* Save height (for ornament and barnobox interference) if topmost slur is up */
if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[
isdat],0) || nolevs == comtrill_1.maxlev)) {
*islhgt = nolevs + iupdn + ivoff;
/* Save height & idcode if top voice and slur start */
if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv
- 1] * 24 - 25] && *islhgt > comsln_1.is1n1) {
comsln_1.is1n1 = *islhgt;
comsln_1.is2n1 = idcode;
}
}
if ((real) ihoff != 0.f) {
shift = ihoff * .1f;
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 1, a__3[1] = "{";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
lform = lfmt1_(&shift);
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + lform - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__3[0] = 2, a__1[0] = "(f";
i__6 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__6);
i__3[1] = 1, a__1[1] = ch__1;
i__3[2] = 3, a__1[2] = ".1)";
ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen)
6), ch__3);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real));
e_wsfi();
lnote += lform;
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 1, a__3[1] = "}";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
/* Zero out ip1 to avoid problems if slur goes to next input blk. */
setbits_(&isdata, &c__8, &c__3, &c__0);
/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */
if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) {
/* levson(midchan(iv,kv)) = nolevs */
/* 130316 */
/* levson(midchan(iv,kv)) = nolevs-iTransAmt(instno(iv)) */
comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] =
nolevs + commvel_1.miditran[cominsttrans_1.instno[
*iv - 1] - 1];
if (settie) {
comslm_1.dbltie = TRUE_;
}
/* Only way settie=T is if we just set a tie ending. So there's also a slur */
/* start here, so set a flag telling addmidi not to zero out levson */
}
} else {
/* Slur is ending. Back thru list to find starting slur */
for (j = isdat - 1; j >= 1; --j) {
if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv ==
igetbits_(&isdat1[j], &c__1, &c__12) + 1) {
if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) {
comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, &
c__28) + (igetbits_(&isdat1[j], &c__1, &
c__18) << 4);
/* 080531 Allow >16 slurs */
if (bit_test(isdat1[j],27)) {
*(unsigned char *)slurudq = 'u';
}
goto L4;
}
}
/* L3: */
}
s_wsle(&io___451);
do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19);
e_wsle();
stop1_();
L4:
/* Bugfix 070901 for slur ending on rest in 2-voice staff */
/* if (nolevs.eq.0 .or. nolevs.gt.60) then */
if (nolevs <= 2 || nolevs > 60) {
/* Ending is on a rest, reset nolevs to default starting height */
nolevs = igetbits_(&isdat2[j], &c__7, &c__19);
}
if (bit_test(isdat3[isdat],0) || bit_test(isdat3[j],0)) {
/* Deal with \curve or \midslur. isdat is ending, j is start. */
if (bit_test(isdat3[isdat],0)) {
imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32;
} else {
imid = igetbits_(&isdat3[j], &c__6, &c__2) - 32;
}
/* Postscript slurs, and \midslur adjustment is needed. Invoke macro */
/* (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: */
/* Abs(imid) Postscript slur type */
/* 1 f */
/* 2-3 default */
/* 4 h */
/* 5 H */
/* 6+ HH */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 7, a__1[1] = "psforts";
/* Computing MIN */
i__6 = abs(imid);
i__2 = min(i__6,6) + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__3[2] = 1, a__1[2] = ch__2;
s_cat(ch__4, a__1, i__3, &c__3, (ftnlen)9);
addstr_(ch__4, &c__9, soutq, lsout, (ftnlen)9, (ftnlen)80)
;
}
/* Shift slur ending for stem on any note? */
if (! stemup && *(unsigned char *)slurudq == 'd' && *tno <
63.f) {
if (! pstie) {
ihoff += -8;
} else {
ihoff += -3;
}
}
if (iscrd) {
/* Shift termination for shifted notehead? */
if (bit_test(isdat2[isdat],1)) {
/* Left-shifted chord notehead. ASSUME downstem. */
if (nolevs == comtrill_1.minlev && *(unsigned char *)
slurudq == 'd') {
ihoff += -2;
} else {
ihoff += -10;
}
} else if (bit_test(isdat2[isdat],2)) {
/* Right shifted chord notehead. ASSUME upstem. */
if (nolevs == comtrill_1.maxlev && *(unsigned char *)
slurudq == 'u') {
ihoff += 2;
} else {
ihoff += 10;
}
}
}
if (ihoff == 0) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__5[0] = 1, a__3[0] = ch__1;
i__5[1] = 5, a__3[1] = "tslur";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
lnote = 6;
} else {
/* Shift needed */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__5[0] = 1, a__3[0] = ch__1;
i__5[1] = 2, a__3[1] = "ts";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
lnote = 3;
}
/* Switch to postscript tie */
if (pstie) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 8, a__1[1] = "tieforts";
i__3[2] = lnote, a__1[2] = notexq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote += 9;
}
/* Print 13-ndxslur */
/* 5/25/08 Allow 14 slurs */
if (23 - comslur_1.ndxslur < 10) {
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__2 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__1;
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
} else if (23 - comslur_1.ndxslur < 20) {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{1";
i__2 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 2, a__2[1] = "{2";
i__2 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[2] = 1, a__2[2] = ch__1;
i__4[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79);
lnote += 4;
}
if (bit_test(*iornq,11) || bit_test(*iornq,12)) {
/* Raise or lower slur by one unit provided . or _ is on same side as slur */
ivoffinc = 0;
if (stemup && *(unsigned char *)slurudq == 'd' || !
stemup && *(unsigned char *)slurudq == 'u') {
if (stemup) {
ivoffinc = -1;
} else {
ivoffinc = 1;
}
if ((stemup && *nolev >= *ncm - 2 || ! stemup && *
nolev <= *ncm + 2) && (i__2 = *ncm - *nolev,
abs(i__2)) % 2 == 0) {
ivoffinc <<= 1;
}
}
ivoff += ivoffinc;
}
i__2 = nolevs + iupdn + ivoff;
notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8);
if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[
isdat],0) || nolevs == comtrill_1.maxlev)) {
*islhgt = nolevs + iupdn + ivoff;
/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */
if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv
- 1] * 24 - 25] && comsln_1.is1n1 > 0) {
if (idcode == comsln_1.is2n1) {
comsln_1.is1n1 = 0;
}
}
}
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = lnoten, a__3[1] = noteq;
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
lnote += lnoten;
if (ihoff != 0) {
shift = ihoff * .1f;
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 1, a__3[1] = "{";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
lform = lfmt1_(&shift);
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + lform - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__3[0] = 2, a__1[0] = "(f";
i__6 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__6);
i__3[1] = 1, a__1[1] = ch__1;
i__3[2] = 3, a__1[2] = ".1)";
ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen)
6), ch__3);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real));
e_wsfi();
lnote += lform;
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 1, a__3[1] = "}";
s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79);
++lnote;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
/* Clear the bit from list of slurs in use */
comslur_1.listslur = bit_clear(comslur_1.listslur,
comslur_1.ndxslur);
/* Zero out the entire strings for start and stop */
isdata = 0;
isdat2[isdat] = 0;
isdat3[isdat] = 0;
isdat4[isdat] = 0;
isdat1[j] = 0;
isdat2[j] = 0;
isdat3[j] = 0;
isdat4[j] = 0;
/* Set midi info for slur ending */
if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) {
icm = commidi_1.midchan[*iv + *kv * 24 - 25];
if (comslm_1.slmon[icm]) {
/* if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then */
/* 130316 */
/* if (nolevs-iTransAmt(instno(iv)).eq.levson(icm) .and. */
if (nolevs + commvel_1.miditran[cominsttrans_1.instno[
*iv - 1] - 1] == comslm_1.levson[icm] && (7 &
*nacc) == 0) {
/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */
/* levsoff(icm) = nolevs */
/* 130316 */
/* levsoff(icm) = nolevs-iTransAmt(instno(iv)) */
comslm_1.levsoff[icm] = nolevs +
commvel_1.miditran[cominsttrans_1.instno[*
iv - 1] - 1];
settie = TRUE_;
} else {
comslm_1.levsoff[icm] = 0;
comslm_1.levson[icm] = 0;
comslm_1.slmon[icm] = FALSE_;
}
}
}
}
isdat1[isdat] = isdata;
}
/* L1: */
}
/* Clear and collapse the slur data list */
numdrop = 0;
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
if (isdat1[isdat] == 0) {
++numdrop;
} else if (numdrop > 0) {
isdat1[isdat - numdrop] = isdat1[isdat];
isdat2[isdat - numdrop] = isdat2[isdat];
isdat3[isdat - numdrop] = isdat3[isdat];
isdat4[isdat - numdrop] = isdat4[isdat];
isdat1[isdat] = 0;
isdat2[isdat] = 0;
isdat3[isdat] = 0;
isdat4[isdat] = 0;
}
/* L2: */
}
*nsdat -= numdrop;
/* call report(nsdat,isdat1,isdat2) */
return 0;
} /* dopsslur_ */
/* Subroutine */ int doslur_(integer *nolev, integer *isdat1, integer *isdat2,
integer *isdat3, integer *nsdat, integer *ip, integer *iv, integer *
kv, integer *nv, logical *beamon, integer *ncm, char *soutq, integer *
lsout, char *ulq, integer *islur, integer *ipl, integer *iornq,
integer *islhgt, real *tno, integer *nacc, ftnlen soutq_len, ftnlen
ulq_len)
{
/* System generated locals */
address a__1[3], a__2[2], a__3[4];
integer i__1, i__2, i__3[3], i__4[2], i__5[4], i__6;
char ch__1[1], ch__2[6];
icilist ici__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer ivoffinc;
extern integer igetbits_(integer *, integer *, integer *);
static integer j, icm;
extern integer log2_(integer *);
static integer imid;
extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char *
, ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *,
integer *, integer *, integer *, integer *, integer *);
extern integer lfmt1_(real *);
extern /* Subroutine */ int stop1_(void);
static integer ihoff;
static logical iscrd;
static integer isdat, ivoff;
static real shift;
static integer iupdn, lform, lnote;
static char noteq[8];
static logical tmove;
static integer idcode, isdata;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer isdats;
static logical settie, sfound, tfound;
static integer isdatt;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer nolevt, nolevs;
extern /* Subroutine */ int printl_(char *, ftnlen);
static logical stemup;
static char notexq[79];
static integer lnoten;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
static integer numdrop;
static char slurudq[1];
/* Fortran I/O blocks */
static cilist io___472 = { 0, 6, 0, 0, 0 };
static cilist io___474 = { 0, 6, 0, 0, 0 };
static cilist io___475 = { 0, 6, 0, 0, 0 };
static cilist io___476 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___484 = { 0, 6, 0, 0, 0 };
/* Called once per main note. (5/26/02) for non-ps slurs only */
/* 130316 */
/* Bits in isdat1: */
/* 13-17 iv */
/* 3-10 ip */
/* 11 start/stop switch */
/* 12 kv-1 */
/* 19-25 ichar(code$) */
/* 26 force direction? */
/* 27 forced dir'n = up if on, set in sslur; also */
/* final direction, set in doslur when beam is started, used on term. */
/* 28-31 ndxslur, set in doslur when beam is started, used on term. */
/* Bits in isdat2 */
/* 0 Chord switch. Not set on main note. */
/* 1-2 left/right notehead shift. Set only for chord note. */
/* 3 tie positioning */
/* 4 dotted flag */
/* 6-11 voff1 1-63 => -31...+31 */
/* 12-18 hoff1 1-127 => -6.3...+6.3 */
/* 19-25 nolev */
/* Bits in isdat3: Only used for slur endings */
/* 0 set if midslur (at least one argument) */
/* 1 set if curve (2 more args) */
/* 2-7 32+first arg (height correction) (1st arg may be negative) */
/* 8-10 second arg (initial slope) */
/* 11-13 third arg (closing slope) */
/* In listslur bit ib is on if slur index ib is in use, ib=0-23. */
/* ndxslur = slur index */
/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */
/* s-slur is blank (idcode=32), t-slur is idcode=1. */
/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */
/* Ivoff will be set for ./_ only if no user-defined shift is specified. */
/* If highest note has upslur, save slur height in islhgt in case */
/* ornament must be moved. */
/* Parameter adjustments */
--isdat3;
--isdat2;
--isdat1;
/* Function Body */
*islhgt = 0;
if (*beamon) {
stemup = *(unsigned char *)ulq == 'u';
} else if (commvl_1.nvmx[*iv - 1] == 2) {
if (! bit_test(*islur,30)) {
/* Single note, 2 lines of music, stem direction not forced */
stemup = commvl_1.ivx > *nv;
} else {
stemup = bit_test(*islur,17);
}
} else {
udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], &
commvl_1.ivx, nv);
stemup = *(unsigned char *)&ch__1[0] == 'u';
}
iscrd = bit_test(*ipl,10);
if (bit_test(*islur,1)) {
/* 't'-slur (idcode=1) somewhere on this note. Find it, check height against */
/* 's'-slur (idcode=32) */
sfound = FALSE_;
tfound = FALSE_;
tmove = FALSE_;
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
if (*iv == igetbits_(&isdat1[isdat], &c__5, &c__13) && *ip ==
igetbits_(&isdat1[isdat], &c__8, &c__3) && *kv ==
igetbits_(&isdat1[isdat], &c__1, &c__12) + 1) {
if (! tfound) {
tfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 1;
if (tfound) {
nolevt = igetbits_(&isdat2[isdat], &c__7, &c__19);
isdatt = isdat;
if (sfound) {
goto L6;
}
}
}
if (! sfound) {
sfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 32;
if (sfound) {
nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19);
isdats = isdat;
if (tfound) {
goto L6;
}
}
}
}
/* L5: */
}
/* Will come thru here if there is a t with no s, so comment out the following */
/* print*,'Did not find s+t-slurs in doslur' */
L6:
if (sfound && tfound) {
tmove = nolevs == nolevt && (bit_test(isdat1[isdats],11) &&
bit_test(isdat1[isdatt],11) || ! bit_test(isdat1[isdats],
11) && ! bit_test(isdat1[isdatt],11));
}
/* Check if 2 starts or two stops */
/* This is a flag for later changing slur level, after we know slur dir'n. */
}
if (commidi_1.ismidi) {
settie = FALSE_;
comslm_1.dbltie = FALSE_;
}
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
isdata = isdat1[isdat];
if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(&
isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, &
c__12) + 1) {
/* Since iv and kv match, ivx will be correct */
idcode = igetbits_(&isdata, &c__7, &c__19);
ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32;
ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64;
iupdn = 0;
*(unsigned char *)slurudq = 'd';
nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19);
if (bit_test(isdata,11)) {
/* Turnon, */
if (nolevs == 0 || nolevs > 60) {
/* Note was a rest, cannot start slur on rest. */
s_wsle(&io___472);
e_wsle();
printl_("Cannot start slur on a rest", (ftnlen)27);
stop1_();
}
/* Get slur direction */
if (bit_test(isdata,26)) {
/* Force slur direction */
if (bit_test(isdata,27)) {
*(unsigned char *)slurudq = 'u';
}
} else if (commvl_1.nvmx[*iv - 1] == 1) {
/* Only one voice per line */
if (! (*beamon)) {
/* Separate note. */
udfq_(ch__1, (ftnlen)1, nolev, ncm);
*(unsigned char *)slurudq = *(unsigned char *)&ch__1[
0];
} else {
/* In a beam */
if (*(unsigned char *)ulq != 'u') {
*(unsigned char *)slurudq = 'u';
}
}
if (iscrd) {
if (nolevs > *ncm) {
*(unsigned char *)slurudq = 'u';
} else {
*(unsigned char *)slurudq = 'd';
}
}
} else {
/* Two voices per line. Get default */
if (commvl_1.ivx > *nv) {
*(unsigned char *)slurudq = 'u';
}
/* Upper voice of the two, so up slur */
}
/* Save up/down-ness for use at termination */
if (*(unsigned char *)slurudq == 'u') {
isdata = bit_set(isdata,27);
}
/* End of section for setting slur direction, still in "Turnon" if-block. */
if (idcode == 1 && tmove) {
iupdn = 1;
if (*(unsigned char *)slurudq == 'd') {
iupdn = -1;
}
}
if (bit_test(*iornq,11) || bit_test(*iornq,12)) {
/* Raise or lower slur by one unit provided . or _ is on same side as slur */
ivoffinc = 0;
if (stemup && *(unsigned char *)slurudq == 'd' || !
stemup && *(unsigned char *)slurudq == 'u') {
/* Must move the slur for _ or . */
if (stemup) {
ivoffinc = -1;
} else {
ivoffinc = 1;
}
if ((stemup && *nolev >= *ncm - 2 || ! stemup && *
nolev <= *ncm + 2) && (i__2 = *ncm - *nolev,
abs(i__2)) % 2 == 0) {
ivoffinc <<= 1;
}
ivoff += ivoffinc;
}
}
if (comslur_1.listslur == 16777215) {
s_wsle(&io___474);
e_wsle();
s_wsle(&io___475);
do_lio(&c__9, &c__1, "You1 defined the twenty-fifth slur"
", one too many!", (ftnlen)49);
e_wsle();
s_wsfe(&io___476);
do_fio(&c__1, "You2 defined the twenty-fifth slur, one t"
"oo many!", (ftnlen)49);
e_wsfe();
stop1_();
}
/* Get index of next slur not in use, starting from ? down */
i__2 = 16777215 - comslur_1.listslur;
comslur_1.ndxslur = log2_(&i__2);
/* Record slur index */
comslur_1.listslur = bit_set(comslur_1.listslur,
comslur_1.ndxslur);
/* Save for use on termination */
/* call setbits(isdata,4,28,ndxslur) */
/* 080531 Allow >16 slurs */
i__2 = comslur_1.ndxslur % 16;
setbits_(&isdata, &c__4, &c__28, &i__2);
i__2 = comslur_1.ndxslur / 16;
setbits_(&isdata, &c__1, &c__18, &i__2);
/* Shift for stem? */
if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f)
{
ihoff += 8;
}
if (bit_test(isdat2[isdat],3)) {
/* Tie spacing, (slur start) */
if (*(unsigned char *)slurudq == 'd') {
++ivoff;
ihoff += 8;
} else if (*(unsigned char *)slurudq == 'u') {
--ivoff;
if (! (stemup && *tno < 63.f)) {
ihoff += 8;
}
/* (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') */
}
}
if (iscrd) {
/* Additional horiz shifts for h-shifted noteheads? */
if (bit_test(isdat2[isdat],1)) {
/* Slur start on left-shifted chord notehead. ASSUME downstem. */
if (nolevs == comtrill_1.minlev && *(unsigned char *)
slurudq == 'd') {
ihoff += -2;
} else {
ihoff += -10;
}
} else if (bit_test(isdat2[isdat],2)) {
/* Right shifted chord notehead. ASSUME upstem. */
if (nolevs == comtrill_1.maxlev && *(unsigned char *)
slurudq == 'u') {
ihoff += 2;
} else {
ihoff += 10;
}
}
}
if (ihoff == 0) {
/* Write stuff for non-shifted start */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 5, a__1[1] = "islur";
i__3[2] = 1, a__1[2] = slurudq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 7;
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 2, a__1[1] = "is";
i__3[2] = 1, a__1[2] = slurudq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote = 4;
}
if (bit_test(isdat2[isdat],4)) {
/* Dotted slur */
s_copy(noteq, notexq, (ftnlen)8, (ftnlen)79);
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 6, a__1[1] = "dotted";
i__3[2] = 8, a__1[2] = noteq;
s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79);
lnote += 7;
}
/* Add slur index to string */
/* c Print 11-ndxslur */
/* Print 23-ndxslur */
/* if (11-ndxslur .lt. 10) then */
if (23 - comslur_1.ndxslur < 10) {
/* 5/25/08 Allow 24 slurs */
/* notexq = notexq(1:lnote)//chax(59-ndxslur) */
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__2 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[1] = 1, a__2[1] = ch__1;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
} else if (23 - comslur_1.ndxslur < 20) {
/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 2, a__3[1] = "{1";
i__2 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[2] = 1, a__3[2] = ch__1;
i__5[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 2, a__3[1] = "{2";
i__2 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[2] = 1, a__3[2] = ch__1;
i__5[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79);
lnote += 4;
}
/* Add note name to string */
i__2 = nolevs + iupdn + ivoff;
notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8);
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = lnoten, a__2[1] = noteq;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += lnoten;
/* Save height (for ornament and barnobox interference) if topmost slur is up */
if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[
isdat],0) || nolevs == comtrill_1.maxlev)) {
*islhgt = nolevs + iupdn + ivoff;
/* Save height & idcode if top voice and slur start */
if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv
- 1] * 24 - 25] && *islhgt > comsln_1.is1n1) {
comsln_1.is1n1 = *islhgt;
comsln_1.is2n1 = idcode;
}
}
if ((real) ihoff != 0.f) {
shift = ihoff * .1f;
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
lform = lfmt1_(&shift);
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + lform - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__3[0] = 2, a__1[0] = "(f";
i__6 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__6);
i__3[1] = 1, a__1[1] = ch__1;
i__3[2] = 3, a__1[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen)
6), ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real));
e_wsfi();
lnote += lform;
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
/* Zero out ip1 to avoid problems if slur goes to next input blk. */
setbits_(&isdata, &c__8, &c__3, &c__0);
/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */
if (commidi_1.ismidi && idcode == 32) {
/* levson(midchan(iv,kv)) = nolevs */
/* 130316 */
/* levson(midchan(iv,kv)) = nolevs-iTransAmt(instno(iv)) */
comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] =
nolevs + commvel_1.miditran[cominsttrans_1.instno[
*iv - 1] - 1];
if (settie) {
comslm_1.dbltie = TRUE_;
}
/* Only way settie=T is if we just set a tie ending. So there's also a slur */
/* start here, so set a flag telling addmidi not to zero out levson */
}
} else {
/* Slur is ending. Back thru list to find starting slur */
for (j = isdat - 1; j >= 1; --j) {
if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv ==
igetbits_(&isdat1[j], &c__1, &c__12) + 1) {
if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) {
comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, &
c__28) + (igetbits_(&isdat1[j], &c__1, &
c__18) << 4);
/* 080531 Allow >16 slurs */
if (bit_test(isdat1[j],27)) {
*(unsigned char *)slurudq = 'u';
}
goto L4;
}
}
/* L3: */
}
s_wsle(&io___484);
do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19);
e_wsle();
stop1_();
L4:
if (nolevs == 0 || nolevs > 60) {
/* Ending is on a rest, reset nolevs to default starting height */
nolevs = igetbits_(&isdat2[j], &c__7, &c__19);
}
if (bit_test(isdat3[isdat],0)) {
/* Deal with \curve or \midslur */
imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32;
/* Remember, only dealing with non-ps slurs */
/* Who knows where the following line came from. Removed it 6/30/02 to */
/* restore behavior of non-ps slurs to old way */
/* if (slurudq .eq. 'd') imid = -imid */
/* 3/8/03 added the following */
if (*(unsigned char *)slurudq == 'd') {
imid = -abs(imid);
}
if (bit_test(isdat3[isdat],1)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__4[0] = 1, a__2[0] = ch__1;
i__4[1] = 5, a__2[1] = "curve";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 6;
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__4[0] = 1, a__2[0] = ch__1;
i__4[1] = 7, a__2[1] = "midslur";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 8;
}
if (imid < 0 || imid > 9) {
/* Need brackets */
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
if (imid < -9) {
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 3 - i__2;
ici__1.iciunit = notexq + i__2;
ici__1.icifmt = "(i3)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&imid, (ftnlen)sizeof(
integer));
e_wsfi();
lnote += 3;
} else if (imid < 0 || imid > 9) {
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 2 - i__2;
ici__1.iciunit = notexq + i__2;
ici__1.icifmt = "(i2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&imid, (ftnlen)sizeof(
integer));
e_wsfi();
lnote += 2;
} else {
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 1 - i__2;
ici__1.iciunit = notexq + i__2;
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&imid, (ftnlen)sizeof(
integer));
e_wsfi();
++lnote;
}
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
} else {
/* 1= 63.f) {
ihoff += -8;
}
}
}
if (iscrd) {
/* Shift termination for shifted notehead? */
if (bit_test(isdat2[isdat],1)) {
/* Left-shifted chord notehead. ASSUME downstem. */
if (nolevs == comtrill_1.minlev && *(unsigned char *)
slurudq == 'd') {
ihoff += -2;
} else {
ihoff += -10;
}
} else if (bit_test(isdat2[isdat],2)) {
/* Right shifted chord notehead. ASSUME upstem. */
if (nolevs == comtrill_1.maxlev && *(unsigned char *)
slurudq == 'u') {
ihoff += 2;
} else {
ihoff += 10;
}
}
}
if (ihoff == 0) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__4[0] = 1, a__2[0] = ch__1;
i__4[1] = 5, a__2[1] = "tslur";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 6;
} else {
/* Shift needed */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__4[0] = 1, a__2[0] = ch__1;
i__4[1] = 2, a__2[1] = "ts";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 3;
}
/* Print 23-ndxslur */
/* 5/25/08 Allow 14 slurs (???????????) */
if (23 - comslur_1.ndxslur < 10) {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__2 = 71 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__4[1] = 1, a__2[1] = ch__1;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
} else if (23 - comslur_1.ndxslur < 20) {
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 2, a__3[1] = "{1";
i__2 = 61 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[2] = 1, a__3[2] = ch__1;
i__5[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = 2, a__3[1] = "{2";
i__2 = 51 - comslur_1.ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[2] = 1, a__3[2] = ch__1;
i__5[3] = 1, a__3[3] = "}";
s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79);
lnote += 4;
}
if (bit_test(*iornq,11) || bit_test(*iornq,12)) {
/* Raise or lower slur by one unit provided . or _ is on same side as slur */
ivoffinc = 0;
if (stemup && *(unsigned char *)slurudq == 'd' || !
stemup && *(unsigned char *)slurudq == 'u') {
if (stemup) {
ivoffinc = -1;
} else {
ivoffinc = 1;
}
if ((stemup && *nolev >= *ncm - 2 || ! stemup && *
nolev <= *ncm + 2) && (i__2 = *ncm - *nolev,
abs(i__2)) % 2 == 0) {
ivoffinc <<= 1;
}
}
ivoff += ivoffinc;
}
if (idcode == 1 && tmove) {
/* t-slur height adjustment */
iupdn = 1;
if (*(unsigned char *)slurudq == 'd') {
iupdn = -1;
}
}
i__2 = nolevs + iupdn + ivoff;
notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8);
if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[
isdat],0) || nolevs == comtrill_1.maxlev)) {
*islhgt = nolevs + iupdn + ivoff;
/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */
if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv
- 1] * 24 - 25] && comsln_1.is1n1 > 0) {
if (idcode == comsln_1.is2n1) {
comsln_1.is1n1 = 0;
}
}
}
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = lnoten, a__2[1] = noteq;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += lnoten;
if (ihoff != 0) {
shift = ihoff * .1f;
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
lform = lfmt1_(&shift);
i__2 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + lform - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__3[0] = 2, a__1[0] = "(f";
i__6 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__6);
i__3[1] = 1, a__1[1] = ch__1;
i__3[2] = 3, a__1[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen)
6), ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real));
e_wsfi();
lnote += lform;
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "}";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
/* Clear the bit from list of slurs in use */
comslur_1.listslur = bit_clear(comslur_1.listslur,
comslur_1.ndxslur);
/* Zero out the entire strings for start and stop */
isdata = 0;
isdat2[isdat] = 0;
isdat1[j] = 0;
isdat2[j] = 0;
isdat3[isdat] = 0;
/* Set midi info for slur ending */
if (commidi_1.ismidi && idcode == 32) {
icm = commidi_1.midchan[*iv + *kv * 24 - 25];
if (comslm_1.slmon[icm]) {
/* if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then */
/* 130316 */
/* if (nolevs-iTransAmt(instno(iv)).eq.levson(icm) .and. */
if (nolevs + commvel_1.miditran[cominsttrans_1.instno[
*iv - 1] - 1] == comslm_1.levson[icm] && (7 &
*nacc) == 0) {
/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */
/* levsoff(icm) = nolevs */
/* 130316 */
/* levsoff(icm) = nolevs-iTransAmt(instno(iv)) */
comslm_1.levsoff[icm] = nolevs +
commvel_1.miditran[cominsttrans_1.instno[*
iv - 1] - 1];
settie = TRUE_;
} else {
comslm_1.levsoff[icm] = 0;
comslm_1.levson[icm] = 0;
comslm_1.slmon[icm] = FALSE_;
}
}
}
}
isdat1[isdat] = isdata;
}
/* L1: */
}
/* Clear and collapse the slur data list */
numdrop = 0;
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
if (isdat1[isdat] == 0) {
++numdrop;
} else if (numdrop > 0) {
isdat1[isdat - numdrop] = isdat1[isdat];
isdat2[isdat - numdrop] = isdat2[isdat];
isdat3[isdat - numdrop] = isdat3[isdat];
isdat1[isdat] = 0;
isdat2[isdat] = 0;
isdat3[isdat] = 0;
}
/* L2: */
}
*nsdat -= numdrop;
/* call report(nsdat,isdat1,isdat2) */
return 0;
} /* doslur_ */
/* Subroutine */ int dotmov_(real *updot, real *rtdot, char *soutq, integer *
lsout, integer *iddot, ftnlen soutq_len)
{
/* System generated locals */
address a__1[5], a__2[8], a__3[5];
integer i__1[5], i__2, i__3, i__4[8], i__5[5], i__6;
char ch__1[1], ch__2[22], ch__3[1], ch__4[37], ch__5[15], ch__6[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
static char sq[1];
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern integer lfmt1_(real *);
static integer lnote;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer lfmtup, lfmtrt;
static char notexq[80];
/* iddot = 0 for single dot, 1 for double */
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
lfmtup = lfmt1_(updot);
lfmtrt = lfmt1_(rtdot);
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 80;
ici__1.iciunit = notexq;
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "(a37,f";
i__2 = lfmtup + 48;
chax_(ch__1, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__1;
i__1[2] = 7, a__1[2] = ".1,a2,f";
i__3 = lfmtrt + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__1[3] = 1, a__1[3] = ch__3;
i__1[4] = 7, a__1[4] = ".1,a15)";
ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__5, (ftnlen)22), ch__2);
s_wsfi(&ici__1);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = sq;
i__4[1] = 12, a__2[1] = "makeatletter";
i__4[2] = 1, a__2[2] = sq;
i__4[3] = 3, a__2[3] = "def";
i__4[4] = 1, a__2[4] = sq;
i__4[5] = 12, a__2[5] = "C@Point#1#2{";
i__4[6] = 1, a__2[6] = sq;
i__4[7] = 6, a__2[7] = "PMXpt{";
s_cat(ch__4, a__2, i__4, &c__8, (ftnlen)37);
do_fio(&c__1, ch__4, (ftnlen)37);
do_fio(&c__1, (char *)&(*updot), (ftnlen)sizeof(real));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*rtdot), (ftnlen)sizeof(real));
/* Writing concatenation */
i__5[0] = 1, a__3[0] = "}";
i__6 = *iddot + 48;
chax_(ch__6, (ftnlen)1, &i__6);
i__5[1] = 1, a__3[1] = ch__6;
i__5[2] = 1, a__3[2] = "}";
i__5[3] = 1, a__3[3] = sq;
i__5[4] = 11, a__3[4] = "makeatother";
s_cat(ch__5, a__3, i__5, &c__5, (ftnlen)15);
do_fio(&c__1, ch__5, (ftnlen)15);
e_wsfi();
/* Example of string just created: */
/* \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\ */
lnote = lfmtup + 54 + lfmtrt;
addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80);
return 0;
} /* dotmov_ */
/* Subroutine */ int dotrill_(integer *iv, integer *ip, integer *iornq, char *
noteq, integer *lnoten, char *notexq, integer *lnote, ftnlen
noteq_len, ftnlen notexq_len)
{
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2[2], i__3[3], i__4;
char ch__1[1], ch__2[6];
icilist ici__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen), s_cat(char *, char **,
integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
static integer itr;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nfmt;
static logical tronly;
/* Fortran I/O blocks */
static cilist io___494 = { 0, 6, 0, 0, 0 };
i__1 = comtrill_1.ntrill;
for (itr = 1; itr <= i__1; ++itr) {
if (*iv == comtrill_1.ivtrill[itr - 1] && *ip == comtrill_1.iptrill[
itr - 1]) {
goto L2;
}
/* L1: */
}
s_wsle(&io___494);
do_lio(&c__9, &c__1, "Problem in dotrill. Call Dr. Don", (ftnlen)33);
e_wsle();
s_stop("", (ftnlen)0);
L2:
tronly = comtrill_1.xnsktr[itr - 1] < .01f;
if (tronly) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 9, a__1[1] = "zcharnote";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
*lnote = 10;
} else if (bit_test(*iornq,7)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 6, a__1[1] = "Trille";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
*lnote = 7;
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 6, a__1[1] = "trille";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
*lnote = 7;
}
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
i__3[1] = *lnoten, a__2[1] = noteq;
i__3[2] = 1, a__2[2] = "{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
*lnote = *lnote + *lnoten + 1;
/* Write trill duration to nearest tenth of a noteskip */
if (tronly) {
/* Writing concatenation */
i__3[0] = *lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 6, a__2[2] = "it tr}";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
*lnote += 7;
return 0;
}
if (comtrill_1.xnsktr[itr - 1] < .95f) {
nfmt = 2;
} else if (comtrill_1.xnsktr[itr - 1] < 9.95f) {
nfmt = 3;
} else {
nfmt = 4;
}
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + nfmt - i__1;
ici__1.iciunit = notexq + i__1;
/* Writing concatenation */
i__3[0] = 2, a__2[0] = "(f";
i__4 = nfmt + 48;
chax_(ch__1, (ftnlen)1, &i__4);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 3, a__2[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__2, i__3, &c__3, (ftnlen)6), ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comtrill_1.xnsktr[itr - 1], (ftnlen)sizeof(real));
e_wsfi();
*lnote += nfmt;
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
return 0;
} /* dotrill_ */
/* Subroutine */ int endslur_(logical *stemup, logical *upslur, integer *
nolev, integer *iupdn, integer *ndxslur, integer *ivoff, integer *ncm,
char *soutq, integer *lsout, logical *fontslur, ftnlen soutq_len)
{
/* System generated locals */
address a__1[2], a__2[4];
integer i__1[2], i__2, i__3[4];
char ch__1[1];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static logical shift;
static integer lnote;
static char noteq[8];
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *,
ftnlen);
static integer lnoten;
static char notexq[79];
/* Only called to end slur started in dograce. */
shift = ! (*stemup) && ! (*upslur);
if (! shift) {
/* No shift needed */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 5, a__1[1] = "tslur";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
lnote = 6;
} else {
/* Shift needed */
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 2, a__1[1] = "ts";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
lnote = 3;
}
/* if (ndxslur .lt. 10) then */
/* notexq = notexq(1:lnote)//chax(48+ndxslur) */
/* lnote = lnote+1 */
/* else */
/* notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}' */
/* lnote = lnote+4 */
/* end if */
/* c Print 11-ndxslur */
/* Print 23-ndxslur */
/* if (11-ndxslur .lt. 10) then */
if (23 - *ndxslur < 10) {
/* notexq = notexq(1:lnote)//chax(59-ndxslur) */
/* Writing concatenation */
i__1[0] = lnote, a__1[0] = notexq;
i__2 = 71 - *ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
++lnote;
} else if (23 - *ndxslur < 20) {
/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
i__3[1] = 2, a__2[1] = "{1";
i__2 = 61 - *ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__3[2] = 1, a__2[2] = ch__1;
i__3[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79);
lnote += 4;
} else {
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
i__3[1] = 2, a__2[1] = "{2";
i__2 = 51 - *ndxslur;
chax_(ch__1, (ftnlen)1, &i__2);
i__3[2] = 1, a__2[2] = ch__1;
i__3[3] = 1, a__2[3] = "}";
s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79);
lnote += 4;
}
i__2 = *nolev + *iupdn + *ivoff;
notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8);
/* Writing concatenation */
i__1[0] = lnote, a__1[0] = notexq;
i__1[1] = lnoten, a__1[1] = noteq;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
lnote += lnoten;
if (shift) {
if (*fontslur) {
/* Writing concatenation */
i__1[0] = lnote, a__1[0] = notexq;
i__1[1] = 5, a__1[1] = "{-.6}";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__1[0] = lnote, a__1[0] = notexq;
i__1[1] = 5, a__1[1] = "{-.8}";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
}
lnote += 5;
}
addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80);
return 0;
} /* endslur_ */
/* Subroutine */ int errmsg_(char *lineq, integer *iccount, integer *ibarno,
char *msgq, ftnlen lineq_len, ftnlen msgq_len)
{
/* System generated locals */
address a__1[2], a__2[5], a__3[4];
integer i__1[2], i__2, i__3, i__4[5], i__5[4];
real r__1;
char ch__1[18], ch__2[1], ch__3[1], ch__4[7], ch__5[79];
cilist ci__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), f_open(olist *), s_wsfe(cilist *),
do_fio(integer *, char *, ftnlen), e_wsfe(void), f_clos(cllist *)
;
double r_lg10(real *);
integer i_indx(char *, char *, ftnlen, ftnlen), do_lio(integer *, integer
*, char *, ftnlen);
/* Local variables */
static integer i1, i10;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char outq[78];
static integer iposn, ndigbn, ndignl, nlinep, lenmsg;
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer ibarnop;
/* Fortran I/O blocks */
static cilist io___504 = { 0, 6, 0, 0, 0 };
static cilist io___507 = { 0, 19, 0, "(i6)", 0 };
static cilist io___511 = { 0, 6, 0, "(1x,a)", 0 };
static cilist io___512 = { 0, 15, 0, "(a)", 0 };
static cilist io___515 = { 0, 6, 0, 0, 0 };
static cilist io___516 = { 0, 15, 0, "(a)", 0 };
if (*iccount <= 78) {
s_copy(outq, lineq, (ftnlen)78, (ftnlen)78);
iposn = *iccount;
} else {
/* Writing concatenation */
i__1[0] = 4, a__1[0] = "... ";
i__1[1] = 74, a__1[1] = lineq + 54;
s_cat(outq, a__1, i__1, &c__2, (ftnlen)78);
iposn = *iccount - 50;
}
s_wsle(&io___504);
e_wsle();
ibarnop = *ibarno;
if (c1omget_1.linesinpmxmod == 0 || c1omget_1.nline >
c1omget_1.line1pmxmod + c1omget_1.linesinpmxmod) {
/* Error is in main .pmx file */
/* nlinep = nline-linesinpmxmod */
/* Correct for comments not copied into buffer */
nlinep = truelinecount_1.linewcom[c1omget_1.nline - 1] -
c1omget_1.linesinpmxmod;
} else {
/* Error is in include file */
ibarnop = 0;
nlinep = c1omget_1.nline - c1omget_1.line1pmxmod + 1;
printl_("ERROR in include file named above, description given below",
(ftnlen)58);
}
o__1.oerr = 0;
o__1.ounit = 19;
o__1.ofnmlen = 11;
o__1.ofnm = "pmxaerr.dat";
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
s_wsfe(&io___507);
do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer));
e_wsfe();
cl__1.cerr = 0;
cl__1.cunit = 19;
cl__1.csta = 0;
f_clos(&cl__1);
/* Computing MAX */
r__1 = ibarnop + .1f;
i__2 = 1, i__3 = (integer) (r_lg10(&r__1) + 1);
ndigbn = max(i__2,i__3);
r__1 = nlinep + .1f;
ndignl = (integer) (r_lg10(&r__1) + 1);
lenmsg = i_indx(msgq, "!", msgq_len, (ftnlen)1) - 1;
/* Split off msgq(..) since UNIX compilers don't allow concat substring!!! */
ci__1.cierr = 0;
ci__1.ciunit = 6;
/* Writing concatenation */
i__4[0] = 8, a__2[0] = "(/,a15,i";
i__2 = ndignl + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__4[1] = 1, a__2[1] = ch__2;
i__4[2] = 5, a__2[2] = ",a6,i";
i__3 = ndigbn + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__4[3] = 1, a__2[3] = ch__3;
i__4[4] = 3, a__2[4] = ",$)";
ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1);
s_wsfe(&ci__1);
do_fio(&c__1, " ERROR in line ", (ftnlen)15);
do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer));
do_fio(&c__1, ", bar ", (ftnlen)6);
do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___511);
do_fio(&c__1, msgq, lenmsg);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 15;
/* Writing concatenation */
i__4[0] = 8, a__2[0] = "(/,a15,i";
i__2 = ndignl + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__4[1] = 1, a__2[1] = ch__2;
i__4[2] = 5, a__2[2] = ",a6,i";
i__3 = ndigbn + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__4[3] = 1, a__2[3] = ch__3;
i__4[4] = 3, a__2[4] = ",$)";
ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1);
s_wsfe(&ci__1);
do_fio(&c__1, " ERROR in line ", (ftnlen)15);
do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer));
do_fio(&c__1, ", bar ", (ftnlen)6);
do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___512);
do_fio(&c__1, msgq, lenmsg);
e_wsfe();
i10 = iposn / 10;
i1 = iposn - i10 * 10;
ci__1.cierr = 0;
ci__1.ciunit = 6;
/* Writing concatenation */
i__5[0] = 1, a__3[0] = "(";
i__2 = i10 + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__2;
i__3 = i1 + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__5[2] = 1, a__3[2] = ch__3;
i__5[3] = 4, a__3[3] = "x,a)";
ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4);
s_wsfe(&ci__1);
do_fio(&c__1, "v", (ftnlen)1);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 15;
/* Writing concatenation */
i__5[0] = 1, a__3[0] = "(";
i__2 = i10 + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__2;
i__3 = i1 + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__5[2] = 1, a__3[2] = ch__3;
i__5[3] = 4, a__3[3] = "x,a)";
ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4);
s_wsfe(&ci__1);
do_fio(&c__1, "v", (ftnlen)1);
e_wsfe();
s_wsle(&io___515);
do_lio(&c__9, &c__1, outq, (ftnlen)78);
e_wsle();
s_wsfe(&io___516);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = " ";
i__1[1] = 78, a__1[1] = outq;
s_cat(ch__5, a__1, i__1, &c__2, (ftnlen)79);
do_fio(&c__1, ch__5, (ftnlen)79);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 6;
/* Writing concatenation */
i__5[0] = 1, a__3[0] = "(";
i__2 = i10 + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__2;
i__3 = i1 + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__5[2] = 1, a__3[2] = ch__3;
i__5[3] = 4, a__3[3] = "x,a)";
ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4);
s_wsfe(&ci__1);
do_fio(&c__1, "^", (ftnlen)1);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 15;
/* Writing concatenation */
i__5[0] = 1, a__3[0] = "(";
i__2 = i10 + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__5[1] = 1, a__3[1] = ch__2;
i__3 = i1 + 48;
chax_(ch__3, (ftnlen)1, &i__3);
i__5[2] = 1, a__3[2] = ch__3;
i__5[3] = 4, a__3[3] = "x,a)";
ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4);
s_wsfe(&ci__1);
do_fio(&c__1, "^", (ftnlen)1);
e_wsfe();
return 0;
} /* errmsg_ */
/* Subroutine */ int eskb4_(integer *ip, integer *ivx, integer *in, integer *
ib, real *space, real *tstart, real *fbar, integer *itrpt, real *esk)
{
/* System generated locals */
real r__1;
/* Builtin functions */
integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *,
char *, ftnlen), e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer iib;
extern doublereal feon_(real *);
static integer itnd, nnsk, itprev;
/* Fortran I/O blocks */
static cilist io___521 = { 0, 6, 0, 0, 0 };
/* Get elemskips to previous note. Called only for graces, no xtups involved. */
/* Parameter adjustments */
--tstart;
--space;
/* Function Body */
itnd = i_nint(&all_1.to[*in - 1]);
if (*ip == 1 || itnd == *itrpt) {
/* Start of bar or after rpt. */
*esk = *fbar;
return 0;
} else {
*esk = 0.f;
itprev = itnd - all_1.nodur[*ivx + (*ip - 1) * 24 - 25];
for (iib = *ib; iib >= 1; --iib) {
if (tstart[iib] < itprev + comtol_1.tol) {
/* This is the block */
r__1 = (real) (itnd - itprev) / space[iib];
nnsk = i_nint(&r__1);
*esk += nnsk * feon_(&space[iib]);
return 0;
} else {
r__1 = (itnd - tstart[iib]) / space[iib];
nnsk = i_nint(&r__1);
*esk += nnsk * feon_(&space[iib]);
itnd = i_nint(&tstart[iib]);
}
/* L1: */
}
}
s_wsle(&io___521);
do_lio(&c__9, &c__1, "Problem in eskb4. Send files to Dr. Don", (ftnlen)
40);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* eskb4_ */
doublereal f1eon_(real *time)
{
/* System generated locals */
real ret_val;
/* Builtin functions */
double sqrt(doublereal);
ret_val = sqrt(*time / 2);
return ret_val;
} /* f1eon_ */
doublereal feon_(real *time)
{
/* System generated locals */
real ret_val;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), pow_dd(doublereal *, doublereal *);
d__1 = (doublereal) sqrt(*time / 2);
d__2 = (doublereal) (1.f - comeon_1.eonk);
ret_val = pow_dd(&d__1, &d__2) * comeon_1.ewmxk;
return ret_val;
} /* feon_ */
/* Subroutine */ int findbeam_(integer *ibmrep, integer *numbms, integer *
mapfb)
{
/* Initialized data */
static integer nip1[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };
static integer nip2[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };
static integer nummask[3] = { 29,49,12 };
static integer mask[147] /* was [49][3] */ = { 65535,4095,65520,255,
65280,63,252,16128,64512,15,240,3840,61440,7,14,112,224,1792,3584,
28672,57344,3,12,48,192,768,3072,12288,49152,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,16777215,65535,16776960,4095,65520,1048320,
16773120,255,65280,16711680,63,252,16128,64512,4128768,16515072,
15,60,240,3840,15360,61440,983040,3932160,15728640,7,14,112,224,
1792,3584,28672,57344,458752,917504,7340032,14680064,3,12,48,192,
768,3072,12288,49152,196608,786432,3145728,12582912,4095,255,4080,
15,240,3840,3,12,48,192,768,3072,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };
static logical eqonly[147] /* was [49][3] */ = { TRUE_,TRUE_,TRUE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_ };
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Builtin functions */
integer lbit_shift(integer, integer), s_wsle(cilist *), do_lio(integer *,
integer *, char *, ftnlen), e_wsle(void);
double r_mod(real *, real *);
/* Local variables */
static integer ib, ip, ir, it, is, ib1, ib2, ir1, is1, is2, it2, iip, ipr[
248], itr[248], mape, mapm, irep, maps, nreal, itend, itoff,
maskm, nodue[248], itseg, mtemp;
static logical short__[248];
static integer itnow, ithalf, numnew;
extern /* Subroutine */ int logbeam_(integer *, integer *, integer *);
static integer masknow;
/* Fortran I/O blocks */
static cilist io___555 = { 0, 6, 0, 0, 0 };
/* Called once per voice per bar, after setting forced beams. */
/* integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16), */
/* * itr(48),nodue(48) */
/* logical short(48),eqonly */
/* Parameter adjustments */
--mapfb;
--numbms;
/* Function Body */
ip = 0;
nreal = 0;
itnow = 0;
L1:
++ip;
if (ip > all_1.nn[commvl_1.ivx - 1]) {
goto L9;
}
L11:
if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) {
/* Ignore all xtup notes except the last, the one with nodur > 0 . */
/* Xtups are irrelevant here since they are already all in forced beams. */
/* Will update itnow by nodur at the END of this loop */
++ip;
goto L11;
}
++nreal;
nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25];
short__[nreal - 1] = nodue[nreal - 1] < 16 && ! bit_test(all_1.irest[
commvl_1.ivx + ip * 24 - 25],0) && ! bit_test(all_1.islur[
commvl_1.ivx + ip * 24 - 25],18);
/* Rule out notes that have 'alone'-flag set */
ipr[nreal - 1] = ip;
itr[nreal - 1] = itnow;
if (nodue[nreal - 1] == 1) {
/* 64th gap */
if (itnow % 2 == 0) {
/* Start of 32nd gap, lump with following note */
++ip;
nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25] + 1;
itnow += nodue[nreal - 1];
} else {
/* End of 32nd gap, lump with preceeding note */
--nreal;
++nodue[nreal - 1];
++itnow;
}
} else {
itnow += all_1.nodur[commvl_1.ivx + ip * 24 - 25];
}
goto L1;
L9:
ir1 = 1;
itseg = all_1.lenbar / *ibmrep;
i__1 = *ibmrep;
for (irep = 1; irep <= i__1; ++irep) {
/* Set bitmaps for all shorts neighbored by a short. Each bit represents a */
/* span of 32nd note. maps, mapm, mape record start, full duration, and end */
/* of consecutive span of beamable (<1/4) notes. */
maps = 0;
mapm = 0;
mape = 0;
itend = itseg * irep;
itoff = itend - itseg;
i__2 = nreal;
for (ir = ir1; ir <= i__2; ++ir) {
it2 = itr[ir - 1] + nodue[ir - 1] - 2;
if (it2 >= itend) {
ir1 = ir;
goto L14;
}
/* if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal */
/* Computing MAX */
i__3 = ir - 1;
if (short__[ir - 1] && (ir > 1 && short__[max(i__3,1) - 1] || ir <
nreal && short__[ir])) {
ib1 = (itr[ir - 1] - itoff) / 2;
ib2 = (it2 - itoff) / 2;
if (max(ib1,ib2) > 47 || ir > 48 || min(ib1,ib2) < 0) {
return 0;
}
/* Must have an odd number obe beats in a long bar. Auto-beam won't work */
nip1[ib1] = ipr[ir - 1];
nip2[ib2] = ipr[ir - 1];
/* nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip */
maps = bit_set(maps,ib1);
mape = bit_set(mape,ib2);
i__3 = ib2;
for (ib = ib1; ib <= i__3; ++ib) {
mapm = bit_set(mapm,ib);
/* L3: */
}
}
/* L2: */
}
L14:
if (mapm == 0) {
goto L13;
}
/* Zero out bits from forced beams */
maps &= ~ mapfb[irep];
mapm &= ~ mapfb[irep];
mape &= ~ mapfb[irep];
/* Compare map with template. */
i__2 = nummask[combeam_1.ibmtyp - 1];
for (it = 1; it <= i__2; ++it) {
masknow = mask[it + combeam_1.ibmtyp * 49 - 50];
if ((masknow & mapm) == masknow) {
/* Find least significant bit in the mask to check start time */
mtemp = masknow;
maskm = masknow;
for (is1 = 0; is1 <= 47; ++is1) {
if ((1 & mtemp) == 1) {
goto L6;
}
mtemp = lbit_shift(mtemp, (ftnlen)-1);
/* L5: */
}
L6:
if ((lbit_shift((ftnlen)1, is1) & maps) == 0) {
goto L4;
}
/* is1 is the bit where the beam starts. Continue shifting to */
/* find most significant bit in the mask to check ending time */
for (is2 = is1; is2 <= 47; ++is2) {
mtemp = lbit_shift(mtemp, (ftnlen)-1);
if ((1 & ~ mtemp) == 1) {
goto L8;
}
/* L7: */
}
L8:
/* is2 is now the bit on which the beam ends. */
if ((lbit_shift((ftnlen)1, is2) & mape) == 0) {
goto L4;
}
/* Did we pick out a single note from the middle of a longer sequence? */
if (nip1[is1] == nip2[is2]) {
goto L4;
}
/* We almost have a beam. Check equality of notes if needed. */
if (eqonly[it + combeam_1.ibmtyp * 49 - 50]) {
i__3 = nip2[is2];
for (ip = nip1[is1]; ip <= i__3; ++ip) {
if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] != 8) {
/* There is a non-1/8th note in this beam. Exit if not 2 quarters */
if (is2 - is1 != 15) {
goto L4;
}
/* Beam is 2 quarters long. Check if can split in half. */
ithalf = 0;
i__4 = nip2[is2];
for (iip = nip1[is1]; iip <= i__4; ++iip) {
ithalf += all_1.nodur[commvl_1.ivx + iip * 24
- 25];
if (ithalf > 16) {
goto L4;
}
if (ithalf == 16) {
goto L21;
}
/* L20: */
}
s_wsle(&io___555);
do_lio(&c__9, &c__1, "Problem in findbeam, pleas"
"e call Dr. Don", (ftnlen)40);
e_wsle();
goto L4;
L21:
/* Otherwise, split in half by keeping only the first half. Other half will */
/* be picked up later, assuming masks are listed longest first. */
is2 = is1 + 7;
/* Reset maskm (since only used part of mask), used later to zero out */
/* bits that contain beams */
maskm = 0;
i__4 = is2;
for (is = is1; is <= i__4; ++is) {
maskm = bit_set(maskm,is);
/* L15: */
}
goto L16;
}
/* L10: */
}
}
L16:
/* This is a beam. If last "effective" ends on odd 64th, add 1 more */
/* if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) */
/* * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then */
r__2 = all_1.to[comipl2_1.ipl2[commvl_1.ivx + nip2[is2] * 24
- 25] - 1] + all_1.nodur[commvl_1.ivx + nip2[is2] *
24 - 25] + comtol_1.tol * .5f;
if ((r__1 = r_mod(&r__2, &c_b1659), dabs(r__1)) >
comtol_1.tol) {
++nip2[is2];
}
++numbms[commvl_1.ivx];
numnew = numbms[commvl_1.ivx];
logbeam_(&numnew, &nip1[is1], &nip2[is2]);
/* Zero out the appropriate bits so these notes don't get used again */
mapm &= ~ maskm;
if (mapm == 0) {
goto L13;
}
maps &= ~ maskm;
mape &= ~ maskm;
}
L4:
;
}
L13:
;
}
return 0;
} /* findbeam_ */
/* Subroutine */ int findeonk_(integer *nptr1, integer *nptr2, real *wovera,
real *xelsk, real *dtmin, real *dtmax, real *eonk0)
{
/* System generated locals */
integer i__1;
real r__1;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), log(
doublereal);
/* Local variables */
static real f, fp;
extern doublereal feon_(real *);
static real targ, esum;
static integer iptr;
extern doublereal f1eon_(real *);
static real desum, dsoln;
static integer niter;
static real detarg;
extern /* Subroutine */ int printl_(char *, ftnlen);
/* Compute an exponent eonk for use in the "flattened" formula for elemskips */
/* vs time. We must solve the eqution f = 0. Initial quess is eonk0. */
comeon_1.eonk = *eonk0;
niter = 0;
L1:
d__1 = (doublereal) f1eon_(dtmax);
d__2 = (doublereal) comeon_1.eonk;
comeon_1.ewmxk = pow_dd(&d__1, &d__2);
++niter;
esum = 0.f;
desum = 0.f;
i__1 = *nptr2;
for (iptr = *nptr1; iptr <= i__1; ++iptr) {
targ = c1omnotes_1.durb[iptr - 1] / c1omnotes_1.sqzb[iptr - 1];
esum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] *
feon_(&targ);
d__1 = (doublereal) (*dtmax / targ);
d__2 = (doublereal) comeon_1.eonk;
detarg = sqrt(targ / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / targ);
desum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] *
detarg;
/* L2: */
}
f = *wovera * feon_(dtmin) - *xelsk - esum;
d__1 = (doublereal) (*dtmax / *dtmin);
d__2 = (doublereal) comeon_1.eonk;
fp = *wovera * sqrt(*dtmin / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / *
dtmin) - desum;
if (dabs(fp) < comtol_1.tol || (r__1 = comeon_1.eonk - .5f, dabs(r__1)) >
.5f || niter > 100) {
printl_("Error in findeonk. Please send source to Dr. Don", (ftnlen)
49);
comeon_1.eonk = 0.f;
comeon_1.ewmxk = 1.f;
return 0;
}
dsoln = -f / fp;
if (dabs(dsoln) < comtol_1.tol * .1f) {
return 0;
}
/* Not converged yet, try again */
comeon_1.eonk += dsoln;
goto L1;
} /* findeonk_ */
doublereal fnote_(integer *nodur, integer *ivx, integer *ip, integer *nacc)
{
/* System generated locals */
real ret_val;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
static integer iip, ip1m1;
extern /* Subroutine */ int stop1_(void);
static integer ndoub, ipback;
extern /* Subroutine */ int printl_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___571 = { 0, 6, 0, 0, 0 };
/* This return the real duration of a note */
/* Parameter adjustments */
nacc -= 25;
nodur -= 25;
/* Function Body */
ipback = *ip;
if (nodur[*ivx + *ip * 24] > 0) {
if (*ip > 1) {
/* Check if this is last note of xtup */
if (nodur[*ivx + (*ip - 1) * 24] == 0) {
ipback = *ip - 1;
goto L2;
}
}
ret_val = (real) nodur[*ivx + *ip * 24];
return ret_val;
}
L2:
/* Count back to prior non zero note. Start at ip to avoid neg index if ip=1. */
/* Count how many doubled xtups notes there are from ip-1 to first note. */
ndoub = 0;
for (ip1m1 = ipback; ip1m1 >= 1; --ip1m1) {
if (nodur[*ivx + ip1m1 * 24] > 0) {
goto L4;
}
if (ip1m1 < *ip && bit_test(nacc[*ivx + ip1m1 * 24],18)) {
++ndoub;
}
/* L1: */
}
L4:
/* count forward to next non-0 nodur. Start at ip in case last note of xtup. */
for (iip = *ip; iip <= 200; ++iip) {
/* Count doubled xtup notes from ip to end. */
if (bit_test(nacc[*ivx + iip * 24],18)) {
++ndoub;
}
if (nodur[*ivx + iip * 24] > 0) {
/* fnote = nodur(ivx,iip)/float(iip-ip1m1) */
ret_val = nodur[*ivx + iip * 24] / (real) (iip - ip1m1 + ndoub);
if (bit_test(nacc[*ivx + *ip * 24],18)) {
ret_val *= 2;
} else if (bit_test(nacc[*ivx + *ip * 24],27)) {
ret_val *= 1.5f;
} else if (*ip > 1) {
if (bit_test(nacc[*ivx + (*ip - 1) * 24],27)) {
ret_val *= .5f;
}
}
return ret_val;
}
/* L3: */
}
s_wsle(&io___571);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
printl_("Probable misplaced barline or incorrect meter, stopping", (
ftnlen)55);
/* call printl('Program error in fnote, send source to Dr. Don') */
stop1_();
return ret_val;
} /* fnote_ */
/* Subroutine */ int g1etchar_(char *lineq, integer *iccount, char *charq,
ftnlen lineq_len, ftnlen charq_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ndxm;
extern /* Subroutine */ int read10_(char *, logical *, ftnlen), m1rec1_(
char *, integer *, integer *, integer *, integer *, integer *,
ftnlen);
static integer nbars, ibaroff, ibarcnt;
/* Gets the next character out of lineq*128. If pointer iccount=128 on entry, */
/* then reads in a new line. Resets iccount. Ends program if no more input. */
if (*iccount == 128) {
read10_(lineq, &c1omget_1.lastchar, (ftnlen)128);
if (c1omget_1.lastchar) {
return 0;
}
if (! commac_1.endmac) {
*iccount = 0;
if (! commac_1.mplay) {
++c1omget_1.nline;
}
} else {
commac_1.endmac = FALSE_;
*iccount = commac_1.icchold;
s_copy(lineq, commac_1.lnholdq, (ftnlen)128, (ftnlen)128);
}
if (commac_1.mrecord) {
m1rec1_(lineq, iccount, &ibarcnt, &ibaroff, &nbars, &ndxm, (
ftnlen)128);
}
}
++(*iccount);
*(unsigned char *)charq = *(unsigned char *)&lineq[*iccount - 1];
return 0;
} /* g1etchar_ */
/* Subroutine */ int g1etnote_(logical *loop, integer *ifig, logical *
optimize, logical *fulltrans)
{
/* Initialized data */
static char literq[51*3] = "Literal TeX string cannot start with 4 backs"
"lashes!" "TeX string must have <129 char, end with backslash!"
"Type 2 or 3 TeX string can only start in column 1! ";
/* System generated locals */
address a__1[3], a__2[2], a__3[4];
integer i__1, i__2[3], i__3[2], i__4, i__5, i__6, i__7, i__8[4];
real r__1;
char ch__1[42], ch__2[1], ch__3[55], ch__4[54], ch__5[46];
icilist ici__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle(
void), do_lio(integer *, integer *, char *, ftnlen), s_wsfe(
cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void), s_cmp(char *,
char *, ftnlen, ftnlen), i_nint(real *);
double log(doublereal);
integer pow_ii(integer *, integer *), s_rsfe(cilist *), e_rsfe(void),
s_rsfi(icilist *), e_rsfi(void);
/* Local variables */
extern integer i1fnodur_(integer *, char *, ftnlen);
extern /* Subroutine */ int checkdyn_(char *, integer *, integer *,
ftnlen);
static integer idotform, ndxquote, i__, j;
extern /* Subroutine */ int readmeter_(char *, integer *, integer *,
integer *, ftnlen), getpmxmod_(logical *, char *, ftnlen);
static integer ic, igr, ipm;
static real dum;
static integer ngr, iiv, nbb4, num1, num2;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static logical cdot;
static real fnum;
static char dumq[1], dotq[1], durq[1];
static integer itup;
static real snum;
static integer ntup;
extern /* Subroutine */ int g1etx_(char *, integer *, logical *, logical *
, integer *, real *, real *, ftnlen), stop1_(void), read10_(char *
, logical *, ftnlen);
static real dimen;
static char charq[1];
static integer indxb;
static char lineq[128];
static integer icsav, ndoub, iorig, iinow, iposn, ninow;
extern /* Subroutine */ int getitransinfo_(logical *, integer *, char *,
integer *, integer *, integer *, integer *, integer *, ftnlen);
static integer icclhw;
static char charlq[1];
extern /* Subroutine */ int setmac_(char *, integer *, integer *, integer
*, integer *, char *, char *, integer *, integer *, ftnlen,
ftnlen, ftnlen), chklit_(char *, integer *, integer *, ftnlen);
static logical fulbrp;
extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *,
ftnlen, ftnlen);
static integer literr, mtrdnp;
static real sysflb;
static integer numint, mtrnmp, numnum;
static logical ztrans;
static real fnsyst;
static integer lenbeat;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), getmidi_(integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, logical *, ftnlen),
readnum_(char *, integer *, char *, real *, ftnlen, ftnlen);
static integer mtrdenl, lenmult, numshft;
static logical plusmin;
static real tintstf;
extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen,
ftnlen);
static integer lvoltxt;
/* Fortran I/O blocks */
static cilist io___581 = { 0, 6, 0, 0, 0 };
static cilist io___582 = { 0, 6, 0, 0, 0 };
static cilist io___583 = { 0, 6, 0, 0, 0 };
static cilist io___584 = { 0, 6, 0, 0, 0 };
static cilist io___585 = { 0, 15, 0, "(/a)", 0 };
static cilist io___586 = { 0, 15, 0, "(a11,2x,i3)", 0 };
static cilist io___587 = { 0, 15, 0, 0, 0 };
static cilist io___588 = { 0, 6, 0, 0, 0 };
static cilist io___596 = { 0, 6, 0, 0, 0 };
static cilist io___597 = { 0, 6, 0, 0, 0 };
static cilist io___598 = { 0, 6, 0, 0, 0 };
static cilist io___603 = { 0, 6, 0, 0, 0 };
static cilist io___604 = { 0, 6, 0, 0, 0 };
static cilist io___605 = { 0, 6, 0, 0, 0 };
static cilist io___618 = { 0, 6, 0, 0, 0 };
static cilist io___621 = { 0, 6, 0, 0, 0 };
static cilist io___622 = { 0, 6, 0, 0, 0 };
static cilist io___623 = { 0, 6, 0, 0, 0 };
static cilist io___626 = { 0, 6, 0, 0, 0 };
static cilist io___632 = { 0, 6, 0, 0, 0 };
static cilist io___633 = { 0, 6, 0, 0, 0 };
static cilist io___634 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___635 = { 0, 6, 0, 0, 0 };
static cilist io___636 = { 0, 6, 0, 0, 0 };
static cilist io___637 = { 0, 15, 0, "(a)", 0 };
static cilist io___638 = { 0, 15, 0, "(a)", 0 };
static cilist io___643 = { 0, 6, 0, 0, 0 };
static cilist io___644 = { 0, 15, 0, "(a)", 0 };
static cilist io___648 = { 0, 6, 0, 0, 0 };
static cilist io___649 = { 0, 6, 0, 0, 0 };
static cilist io___650 = { 0, 6, 0, 0, 0 };
static cilist io___651 = { 0, 6, 0, "(1x,a21,i3,a23)", 0 };
static cilist io___655 = { 0, 6, 0, 0, 0 };
static cilist io___656 = { 0, 6, 0, 0, 0 };
static cilist io___657 = { 0, 5, 0, "(a)", 0 };
static cilist io___661 = { 0, 6, 0, 0, 0 };
static cilist io___662 = { 0, 6, 0, 0, 0 };
cdot = FALSE_;
L1:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq != ' ') {
*(unsigned char *)charlq = *(unsigned char *)charq;
}
if (c1omget_1.lastchar) {
if (i_indx("/%", charlq, (ftnlen)2, (ftnlen)1) == 0) {
s_wsle(&io___581);
e_wsle();
s_wsle(&io___582);
do_lio(&c__9, &c__1, "WARNING:", (ftnlen)8);
e_wsle();
s_wsle(&io___583);
do_lio(&c__9, &c__1, "Last non-blank character is \"", (ftnlen)29)
;
do_lio(&c__9, &c__1, charlq, (ftnlen)1);
do_lio(&c__9, &c__1, "\", not \"/,%\"", (ftnlen)12);
e_wsle();
s_wsle(&io___584);
do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11);
i__1 = *(unsigned char *)charlq;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
s_wsfe(&io___585);
/* Writing concatenation */
i__2[0] = 29, a__1[0] = "Last non-blank character is \"";
i__2[1] = 1, a__1[1] = charlq;
i__2[2] = 12, a__1[2] = "\", not \"/,%\"";
s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)42);
do_fio(&c__1, ch__1, (ftnlen)42);
e_wsfe();
s_wsfe(&io___586);
do_fio(&c__1, "ASCII code:", (ftnlen)11);
i__1 = *(unsigned char *)charlq;
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfe();
/* Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. */
--inbuff_1.ilbuf;
inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) (inbuff_1.lbuf[
inbuff_1.ilbuf - 1] + 2);
/* Writing concatenation */
i__3[0] = inbuff_1.ipbuf, a__2[0] = inbuff_1.bufq;
i__3[1] = 2, a__2[1] = " /";
s_cat(inbuff_1.bufq, a__2, i__3, &c__2, (ftnlen)65536);
s_wsle(&io___587);
do_lio(&c__9, &c__1, "appending /", (ftnlen)18);
e_wsle();
s_wsle(&io___588);
do_lio(&c__9, &c__1, "appending /", (ftnlen)18);
e_wsle();
/* Writing concatenation */
i__3[0] = a1ll_2.iccount, a__2[0] = lineq;
i__3[1] = 2, a__2[1] = " /";
s_cat(lineq, a__2, i__3, &c__2, (ftnlen)128);
c1omget_1.lastchar = FALSE_;
goto L1;
}
return 0;
}
if (*(unsigned char *)charq == ' ') {
goto L1;
} else if (*(unsigned char *)charq == '%' && a1ll_2.iccount == 1) {
a1ll_2.iccount = 128;
goto L1;
/* Replacement 1/22/12 since gfortran 4.7 with -O was choking here! */
/* else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. */
} else if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) > 0 || *(
unsigned char *)charq == 'r') {
/* This is a note/rest. gotclef is only used for checking for clef before "/" */
if (cdot) {
goto L28;
}
if (c1omnotes_1.gotclef) {
c1omnotes_1.gotclef = FALSE_;
}
idotform = 0;
numnum = 0;
plusmin = FALSE_;
L28:
++a1ll_2.nnl[c1ommvl_1.ivx - 1];
if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 200) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, ">200 notes in line of mu"
"sic. Use smaller blocks!", (ftnlen)128, (ftnlen)48);
stop1_();
}
*(unsigned char *)dotq = 'x';
/* Check if this is 'r ' and previous note was full-bar-pause */
i__1 = a1ll_2.iccount;
/* Computing MAX */
i__4 = 1, i__5 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1;
/* Computing MAX */
i__6 = 1, i__7 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1;
fulbrp = *(unsigned char *)charq == 'r' && s_cmp(lineq + i__1, " ",
a1ll_2.iccount + 1 - i__1, (ftnlen)1) == 0 && a1ll_2.nnl[
c1ommvl_1.ivx - 1] > 1 && a1ll_2.rest[c1ommvl_1.ivx + max(
i__4,i__5) * 24 - 25] && a1ll_2.nodur[c1ommvl_1.ivx + max(
i__6,i__7) * 24 - 25] == a1ll_2.lenbar;
L2:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
ic = *(unsigned char *)durq;
if (ic <= 57 && ic >= 48) {
/* Digit */
if (numnum == 0) {
c1omnotes_1.nnodur = ic - 48;
numnum = 1;
goto L2;
} else if (numnum == 1) {
if (*(unsigned char *)charq == 'r') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only one digit a"
"llowed after rest symbol \"r\"!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
numnum = 2;
if (plusmin) {
s_wsle(&io___596);
e_wsle();
s_wsle(&io___597);
do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen)
25);
e_wsle();
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1"
".2, +/- was ignored if octave was!", (ftnlen)128,
(ftnlen)50);
s_wsle(&io___598);
do_lio(&c__9, &c__1, "explicitly specified. May need to"
" edit old editions", (ftnlen)52);
e_wsle();
}
goto L2;
} else {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, ">2 digits in note sy"
"mbol!", (ftnlen)128, (ftnlen)25);
stop1_();
}
} else if (*(unsigned char *)durq == 'd') {
*(unsigned char *)dotq = *(unsigned char *)durq;
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "d", a1ll_2.iccount + 1 - i__1, (ftnlen)1)
== 0) {
c1omnotes_1.iddot = 1;
++a1ll_2.iccount;
/* Since we flow out, double dots won't work with other dot options */
}
i__1 = a1ll_2.iccount;
if (i_indx("+-", lineq + i__1, (ftnlen)2, a1ll_2.iccount + 1 -
i__1) > 0) {
/* move a dot, provided a number follows. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) == 0)
{
/* Backup, exit the loop normally */
a1ll_2.iccount += -2;
goto L2;
}
readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
/* Vertical shift also */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) ==
0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected num"
"ber after 2nd +/- (shift dot)!", (ftnlen)128,
(ftnlen)42);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128,
(ftnlen)1);
}
--a1ll_2.iccount;
}
goto L2;
} else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Accidental shift */
/* if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then */
i__1 = a1ll_2.iccount - 2;
if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 -
i__1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Expected \"f\", \"s\", \"n\" o"
"r \"A\" before \"<\" or \">\"!", (ftnlen)128, (ftnlen)
48);
/* * 'Expected "f", "s", or "n" before "<" or ">"!') */
stop1_();
}
ipm = 1;
if (*(unsigned char *)durq == '<') {
ipm = -1;
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789.0", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected number afte"
"r (accidental shift)!", (ftnlen)128, (ftnlen)45);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
fnum = ipm * fnum;
if (fnum < -5.35f || fnum > 1.f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Horizontal accidental shift mu"
"st be >-5.35 and <1.0!", (ftnlen)128, (ftnlen)52);
stop1_();
}
--a1ll_2.iccount;
goto L2;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
if (*(unsigned char *)charq != 'r') {
i__1 = a1ll_2.iccount - 2;
if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount -
1 - i__1) > 0) {
ipm = 1;
if (*(unsigned char *)durq == '-') {
ipm = -1;
}
i__1 = a1ll_2.iccount;
if (i_indx("0123456789", lineq + i__1, (ftnlen)10,
a1ll_2.iccount + 1 - i__1) > 0) {
/* This may be start of accidental shift, but may be octave jump; then duration */
icsav = a1ll_2.iccount;
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* This is an accid shift since there's a 2nd consecutive signed number. */
/* Check size of 1st number. */
if (fnum > 30.5f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__1, &i__4, "Vertical accid"
"ental shift must be less than 31!", (
ftnlen)128, (ftnlen)47);
stop1_();
}
ipm = 1;
if (*(unsigned char *)durq == '-') {
ipm = -1;
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)
128, (ftnlen)1);
if (i_indx("1234567890.", durq, (ftnlen)11, (
ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expe"
"cted 2nd number of accidental shift)!"
, (ftnlen)128, (ftnlen)41);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (
ftnlen)128, (ftnlen)1);
fnum = ipm * fnum;
if (fnum < -5.35f || fnum > 1.f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__1, &i__4, "Horiz. acciden"
"tal shift must be >-5.35 and <1.0!", (
ftnlen)128, (ftnlen)48);
stop1_();
}
--a1ll_2.iccount;
goto L2;
} else {
/* Not accid shift, reset, then flow out */
a1ll_2.iccount = icsav;
}
}
}
plusmin = TRUE_;
if (numnum == 2) {
s_wsle(&io___603);
e_wsle();
s_wsle(&io___604);
do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen)
25);
e_wsle();
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1"
".2, +/- was ignored if octave was!", (ftnlen)128,
(ftnlen)50);
s_wsle(&io___605);
do_lio(&c__9, &c__1, "explicitly specified. May need to"
" edit old editions", (ftnlen)52);
e_wsle();
}
goto L2;
/* It's a rest containing +|- . Must refer to a vertical shift. Read past. */
} else {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
goto L2;
}
/* else if (index('ulare',durq) .gt. 0) then */
} else if (i_indx("ularec", durq, (ftnlen)6, (ftnlen)1) > 0) {
goto L2;
} else if (*(unsigned char *)durq == 'S') {
/* Stemlength change */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx(".0123456789:", durq, (ftnlen)12, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must be a numb"
"er or colon here!", (ftnlen)128, (ftnlen)37);
stop1_();
}
if (*(unsigned char *)durq == ':') {
if (! comkeys_1.stickys) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned off stick"
"y stemshrinks without turning on!", (ftnlen)128, (
ftnlen)49);
stop1_();
}
comkeys_1.stickys = FALSE_;
goto L2;
}
readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, (ftnlen)
1);
if (dum < .5f || dum > 4.f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Stemlength shortening must be "
"from .5 to 4!", (ftnlen)128, (ftnlen)43);
stop1_();
}
if (*(unsigned char *)durq != ':') {
--a1ll_2.iccount;
} else {
if (comkeys_1.stickys) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on sticky"
" stemshrinks when already on!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
comkeys_1.stickys = TRUE_;
}
goto L2;
} else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */
/* MUST come right after "f,s,n" */
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1)
== 0) {
++a1ll_2.iccount;
}
goto L2;
} else if (*(unsigned char *)durq == 'p') {
fulbrp = *(unsigned char *)charq == 'r';
if (! fulbrp) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "The option \"p\" onl"
"y works with \"r\" (rest)!", (ftnlen)128, (ftnlen)42);
stop1_();
}
goto L2;
} else if (*(unsigned char *)durq == 'b') {
if (*(unsigned char *)charq != 'r') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"b\"; I"
" expected \"rb\"!", (ftnlen)128, (ftnlen)33);
stop1_();
} else if (numnum == 2) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"r\" &"
" \"b\" with two numbers!", (ftnlen)128, (ftnlen)39);
}
goto L2;
} else if (*(unsigned char *)durq == 'x') {
/* Xtuplet. Count number of doubled notes (for unequal xtups) */
if (bit_test(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[
c1ommvl_1.ivx - 1] * 24 - 25],18)) {
ndoub = 1;
} else {
ndoub = 0;
}
/* Will set all durations to 0 except last one. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "First char after \""
"x\" in xtuplet must be \"1\"-\"9\"!", (ftnlen)128, (
ftnlen)48);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
if (fnum > 99.f) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Xtuplet cannot have "
"more than 99 notes!", (ftnlen)128, (ftnlen)39);
stop1_();
} else if (i_indx(" DFnd", durq, (ftnlen)5, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only legal character"
"s here are \" \",\"D\",\"F\",\"n\"!", (ftnlen)128, (
ftnlen)47);
stop1_();
}
/* End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. */
if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double xtup note to make an un= xtup. Here, number already set, but may also */
/* have used this before number was set. */
c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx +
a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],18);
ndoub = 1;
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
} else if (*(unsigned char *)durq == 'd') {
c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx +
a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],27);
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
}
if (*(unsigned char *)durq == 'n') {
/* Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. */
numshft = 0;
L30:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)durq == 'f') {
goto L30;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
++numshft;
if (numshft == 3) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only 2 shift"
"s are allowed after \"n\" in xtup!", (ftnlen)
128, (ftnlen)44);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) ==
0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact"
"er should be a digit or \".\"!", (ftnlen)128,
(ftnlen)40);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128,
(ftnlen)1);
--a1ll_2.iccount;
if (numshft == 1 && snum > 15.1f || numshft == 2 && snum
> 1.51f) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Shift number"
" after \"n\" in xtup is out of range!", (
ftnlen)128, (ftnlen)47);
stop1_();
}
goto L30;
} else if (*(unsigned char *)durq == 's') {
/* Slope alteration for bracket */
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "For slope ad"
"justment, this character must be \"+\" or \"-"
"\"!", (ftnlen)128, (ftnlen)56);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0)
{
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact"
"er should be a digit!", (ftnlen)128, (ftnlen)
33);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128,
(ftnlen)1);
--a1ll_2.iccount;
if (i_nint(&snum) > 15) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slope adjust"
"ment cannot exceed 15!", (ftnlen)128, (ftnlen)
34);
stop1_();
}
goto L30;
} else if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) >
0) {
/* Unsigned integer => alternate printed number */
readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128,
(ftnlen)1);
if (snum > 15.1f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Alternate xtup number "
"after \"n\" must be <16!", (ftnlen)128, (
ftnlen)44);
stop1_();
}
--a1ll_2.iccount;
goto L30;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r after \"n\" in xtup!", (ftnlen)128, (ftnlen)36);
stop1_();
}
}
ntup = i_nint(&fnum);
i__1 = ntup;
for (itup = 2; itup <= i__1; ++itup) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = 0;
++a1ll_2.nnl[c1ommvl_1.ivx - 1];
L110:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)durq == ' ') {
goto L110;
} else if (*(unsigned char *)durq == 'o') {
/* Ornament in xtup. "o" symbol must come AFTER the affected note */
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("(stmx+Tup._)e:>^bc", dumq, (ftnlen)18, (
ftnlen)1) == 0) {
if (i_indx("fg", dumq, (ftnlen)2, (ftnlen)1) > 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Fermata "
"or segno not allowed in xtuplet!", (
ftnlen)128, (ftnlen)40);
} else {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal "
"ornament!", (ftnlen)128, (ftnlen)17);
}
stop1_();
}
if (*(unsigned char *)dumq == 'T') {
/* Trill. may be followed by 't' and/or number. read 'til blank */
L29:
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)dumq != ' ') {
goto L29;
}
} else if (*(unsigned char *)dumq == 'e') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal "
"character after \"e\" in edit. accid. sy"
"mbol!", (ftnlen)128, (ftnlen)51);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)dumq == '?') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)
128, (ftnlen)1);
}
} else if (*(unsigned char *)dumq == ':') {
i__4 = a1ll_2.iccount;
if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 -
i__4, (ftnlen)1) != 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu"
"st be followed by blank in \"o: \"!", (
ftnlen)128, (ftnlen)39);
stop1_();
} else if (! comkeys_1.ornrpt) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &i__4, &i__5, "Turned off repeate"
"d ornaments before they were on!", (
ftnlen)128, (ftnlen)50);
stop1_();
}
comkeys_1.ornrpt = FALSE_;
} else {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
}
if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char"
"acter in ornament symbol!", (ftnlen)128, (
ftnlen)37);
stop1_();
}
if (*(unsigned char *)dumq == ':') {
i__4 = a1ll_2.iccount;
if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 -
i__4, (ftnlen)1) != 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu"
"st be followed by blank in \"o: \"!", (
ftnlen)128, (ftnlen)39);
stop1_();
} else if (comkeys_1.ornrpt) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Turned o"
"n repeated ornaments but already on!", (
ftnlen)128, (ftnlen)44);
stop1_();
}
comkeys_1.ornrpt = TRUE_;
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
i__4 = a1ll_2.iccount;
if (i_indx("0123456789", lineq + i__4, (ftnlen)10,
a1ll_2.iccount + 1 - i__4) == 0) {
i__4 = a1ll_2.iccount + 1;
i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &i__4, &i__5, "There should be an"
" integer here!", (ftnlen)128, (ftnlen)32);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
if (*(unsigned char *)durq == ':') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot s"
"hift AND repeat an ornament!", (ftnlen)
128, (ftnlen)36);
stop1_();
}
/* 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
i__4 = a1ll_2.iccount;
if (i_indx(".0123456789", lineq + i__4, (ftnlen)
11, a1ll_2.iccount + 1 - i__4) == 0) {
i__4 = a1ll_2.iccount + 1;
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__4, &i__5, "There should b"
"e a number here!", (ftnlen)128, (
ftnlen)30);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (
ftnlen)128, (ftnlen)1);
}
}
goto L110;
} else if (i_indx("st(){}", durq, (ftnlen)6, (ftnlen)1) > 0) {
/* Slur in xtup */
iposn = 0;
numint = 0;
L15:
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
++iposn;
if (i_indx("udlbfnht", dumq, (ftnlen)8, (ftnlen)1) > 0) {
if (*(unsigned char *)dumq == 't' && *(unsigned char *
)durq == 't') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot u"
"se \"t\" as an option on a tie!", (ftnlen)
128, (ftnlen)37);
stop1_();
}
goto L15;
} else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
++numint;
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
if (numint == 1) {
if (i_nint(&fnum) > 30) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__4, &i__5, "Magnitude of s"
"lur height adjustment cannot exceed "
"30!", (ftnlen)128, (ftnlen)53);
stop1_();
}
} else if (numint == 2) {
if (dabs(fnum) > 6.3f) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__4, &i__5, "Slur horiz shi"
"ft must be in the range (-6.3,6.3)!",
(ftnlen)128, (ftnlen)49);
stop1_();
}
} else {
/* Third signed integer, must be a midslur or curve spec. */
if (dabs(fnum) > 31.f) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__4, &i__5, "Slur midheight"
" must be in the range (-31,31)!", (
ftnlen)128, (ftnlen)45);
stop1_();
}
if (*(unsigned char *)durq == ':') {
/* Expecting curve parameters. Get two numbers */
for (i__ = 1; i__ <= 2; ++i__) {
++a1ll_2.iccount;
fnum = (real) (*(unsigned char *)&lineq[
a1ll_2.iccount - 1] - 48);
if ((r__1 = fnum - 3.5f, dabs(r__1)) >
3.6f) {
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4,
"Slur curve parameter must "
"be in range (0,7)!", (ftnlen)
128, (ftnlen)44);
stop1_();
}
/* L40: */
}
++a1ll_2.iccount;
}
}
--a1ll_2.iccount;
goto L15;
} else if (*(unsigned char *)dumq == 's') {
/* What follows should be one or two signed numbers for adjustment of line break */
/* slur, end of 1st segment or start of second. */
if (comslur_1.fontslur) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "May not "
"use linebreak slur options with font-bas"
"ed slurs!", (ftnlen)128, (ftnlen)57);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "This cha"
"racter must be \"+\" or \"-\"!", (ftnlen)
128, (ftnlen)34);
stop1_();
}
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)
128, (ftnlen)1);
if (i_nint(&fnum) > 30) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &i__4, &i__5, "Magnitude of slur "
"height adjustment cannot exceed 30!", (
ftnlen)128, (ftnlen)53);
stop1_();
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (
ftnlen)128, (ftnlen)1);
if (dabs(fnum) > 6.3f) {
i__4 = a1ll_2.iccount - 1;
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__4, &i__5, "Slur horiz shi"
"ft must be in range (-6.3,6.3)!", (
ftnlen)128, (ftnlen)45);
stop1_();
}
}
--a1ll_2.iccount;
goto L15;
} else if (*(unsigned char *)dumq == 'H' && iposn > 1) {
i__4 = a1ll_2.iccount;
if (s_cmp(lineq + i__4, "H", a1ll_2.iccount + 1 -
i__4, (ftnlen)1) == 0) {
++a1ll_2.iccount;
}
goto L15;
} else if (*(unsigned char *)dumq == 'p') {
/* local change in postscript slur/tie adjustment default */
if (comslur_1.fontslur) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Must use"
" postscript slurs (\"Ap\") to use this o"
"ption!", (ftnlen)128, (ftnlen)52);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect"
"ed \"+\" or \"-\" here!", (ftnlen)128, (
ftnlen)25);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect"
"ed \"s\" or \"t\" here!", (ftnlen)128, (
ftnlen)25);
stop1_();
}
goto L15;
} else if (*(unsigned char *)dumq != ' ') {
ic = *(unsigned char *)dumq;
if (ic >= 48 && ic <= 57 || ic >= 65 && ic <= 90) {
if (iposn == 1) {
if (*(unsigned char *)durq == 't' &&
comslur_1.fontslur) {
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4,
"Slur ID not allowed on non-post"
"script tie!", (ftnlen)128, (
ftnlen)42);
stop1_();
}
goto L15;
}
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Slur ID "
"must be 2nd character in slur symbol!", (
ftnlen)128, (ftnlen)45);
stop1_();
}
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char"
"acter in slur symbol!", (ftnlen)128, (ftnlen)
33);
stop1_();
}
goto L110;
} else if (i_indx("0123456789#-nx_", durq, (ftnlen)15, (
ftnlen)1) > 0) {
/* We have a figure. Only allow on 1st note of xtup */
if (itup != 2) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Figure in xt"
"up only allowed on 1st note!", (ftnlen)128, (
ftnlen)40);
stop1_();
} else if (*(unsigned char *)durq == 'x') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "No floating "
"figures in xtuplets!", (ftnlen)128, (ftnlen)
32);
stop1_();
}
if (compage_1.usefig && c1ommvl_1.ivx == 1) {
*ifig = 1;
}
L26:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("0123456789#-n_.:", durq, (ftnlen)16, (ftnlen)
1) > 0) {
goto L26;
} else if (*(unsigned char *)durq == 's') {
comligfont_1.isligfont = TRUE_;
goto L26;
} else if (*(unsigned char *)durq == '+') {
/* vertical offset, must be integer then blank */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) !=
0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Integer "
"for vertical offset expected here!", (
ftnlen)128, (ftnlen)42);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Vertical"
" offset must terminate figure!", (ftnlen)
128, (ftnlen)38);
stop1_();
}
--a1ll_2.iccount;
goto L26;
} else if (*(unsigned char *)durq != ' ') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char"
"acter in figure in xtuplet!", (ftnlen)128, (
ftnlen)39);
stop1_();
}
goto L110;
} else if (*(unsigned char *)durq == 'G') {
ngr = 1;
L79:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (
ftnlen)1);
if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0)
{
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
ngr = i_nint(&fnum);
--a1ll_2.iccount;
goto L79;
} else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1)
> 0) {
goto L79;
} else if (*(unsigned char *)charq == 'm') {
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128,
(ftnlen)1);
if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0)
{
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "A digit "
"less than 5 must follow \"m\" in a grace"
" note!", (ftnlen)128, (ftnlen)52);
stop1_();
}
goto L79;
} else if (*(unsigned char *)charq == 'X') {
/* Space before main note */
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128,
(ftnlen)1);
if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen)
1) > 0) {
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (
ftnlen)128, (ftnlen)1);
--a1ll_2.iccount;
goto L79;
} else {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "A number"
" must follow \"X\" in a grace note!", (
ftnlen)128, (ftnlen)41);
stop1_();
}
}
/* At this point, charq is first note name in rest (grace?) */
i__4 = ngr;
for (igr = 1; igr <= i__4; ++igr) {
numnum = 0;
if (igr > 1) {
L75:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)
128, (ftnlen)1);
if (*(unsigned char *)charq == ' ') {
goto L75;
}
}
if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) ==
0) {
i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__5, "In grace"
", expected \"a\"-\"g\"!", (ftnlen)128, (
ftnlen)27);
stop1_();
}
L78:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128,
(ftnlen)1);
if (*(unsigned char *)charq != ' ') {
if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1)
> 0) {
if (numnum == 1) {
i__5 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__5,
"Only one of \"+-1234567\" allow"
"ed here in grace!", (ftnlen)128, (
ftnlen)46);
stop1_();
}
numnum = 1;
goto L78;
} else if (i_indx("+-nfs", charq, (ftnlen)5, (
ftnlen)1) > 0) {
goto L78;
}
/* Digits are possible octave numbers */
i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__5, "Illegal "
"character after note name in grace!", (
ftnlen)128, (ftnlen)43);
stop1_();
}
/* L71: */
}
goto L110;
} else /* if(complicated condition) */ {
chax_(ch__2, (ftnlen)1, &c__92);
if (*(unsigned char *)durq == *(unsigned char *)&ch__2[0])
{
chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128);
if (literr > 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, literq + (
literr - 1) * 51, (ftnlen)128, (ftnlen)51)
;
stop1_();
}
goto L110;
} else if (*(unsigned char *)durq == 'M') {
/* Temporary trap until I get around putting this in pmxb */
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Macros not y"
"et allowed in xtuplets!", (ftnlen)128, (
ftnlen)35);
stop1_();
} else if (*(unsigned char *)durq == 'X') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
g1etx_(lineq, &a1ll_2.iccount, &c_false, &
comkeys_1.shifton, &i__4, &c1omnotes_1.udsp[
c1omnotes_1.ibarcnt + a1ll_2.nbars], &
c1omnotes_1.wheadpt, (ftnlen)128);
goto L110;
} else if (*(unsigned char *)durq == 'z') {
/* Chord note in xtup. Read past for now. */
L33:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq != ' ') {
goto L33;
}
goto L110;
} else if (*(unsigned char *)durq == 'D') {
/* Dynamic mark */
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
checkdyn_(lineq, &a1ll_2.iccount, &i__4, (ftnlen)128);
goto L110;
} else if (*(unsigned char *)durq == '%') {
if (a1ll_2.iccount != 1) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Comment "
"must have \"%\" in column 1!", (ftnlen)
128, (ftnlen)34);
stop1_();
}
a1ll_2.iccount = 128;
goto L110;
} else if (*(unsigned char *)durq == '?') {
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ' ') {
--a1ll_2.iccount;
goto L110;
}
if (*(unsigned char *)durq != '-') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin"
"g \"-\"", (ftnlen)128, (ftnlen)13);
stop1_();
}
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1)
== 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin"
"g number", (ftnlen)128, (ftnlen)16);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
--a1ll_2.iccount;
goto L110;
/* +++ */
} else /* if(complicated condition) */ {
i__4 = a1ll_2.iccount;
i__5 = a1ll_2.iccount + 1;
if (*(unsigned char *)durq == ']' && s_cmp(lineq +
i__4, "[", a1ll_2.iccount + 1 - i__4, (ftnlen)
1) == 0 && s_cmp(lineq + i__5, " ",
a1ll_2.iccount + 2 - i__5, (ftnlen)1) == 0) {
a1ll_2.iccount += 2;
goto L110;
/* +++ */
}
}
}
/* End of xtup options. At this point symbol can only be note or rest */
if (i_indx("abcdefgr", durq, (ftnlen)8, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "In xtup, this ch"
"aracter is not allowed!", (ftnlen)128, (ftnlen)39)
;
stop1_();
} else if (*(unsigned char *)durq == 'r' && itup == ntup) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Sorry, PMX canno"
"t end an xtuplet with a rest!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
L7:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("2345678ulcb", durq, (ftnlen)11, (ftnlen)1) > 0) {
goto L7;
} else if (i_indx("sfn", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. */
i__4 = a1ll_2.iccount;
if (s_cmp(lineq + i__4, "i", a1ll_2.iccount + 1 - i__4, (
ftnlen)1) == 0) {
++a1ll_2.iccount;
}
goto L7;
} else if (i_indx("+-<>", durq, (ftnlen)4, (ftnlen)1) > 0) {
/* May have either octave jump or shifted accid. on main xtup note */
i__4 = a1ll_2.iccount;
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0 &&
i_indx("01234567890", lineq + i__4, (ftnlen)11,
a1ll_2.iccount + 1 - i__4) == 0) {
goto L7;
}
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128,
(ftnlen)1);
--a1ll_2.iccount;
goto L7;
} else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double an xtup note to make an unequal xtup */
c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx -
1] * 24 - 25] = bit_set(c1ommvl_1.nacc[
c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25],18);
++ndoub;
goto L7;
} else if (*(unsigned char *)durq == 'd') {
c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx -
1] * 24 - 25] = bit_set(c1ommvl_1.nacc[
c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25],27);
goto L7;
} else if (*(unsigned char *)durq != ' ') {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal option o"
"n xtuplet note!", (ftnlen)128, (ftnlen)31);
stop1_();
}
if (itup == ntup - ndoub) {
goto L3;
}
/* L6: */
}
L3:
/* 6==End of loop for xtuplet input */
;
} else if (*(unsigned char *)durq == 'm') {
/* Multi-bar rest: next 1 or two digits are # of bars. */
if (a1ll_2.itsofar[a1ll_2.iv - 1] % a1ll_2.lenbar != 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Multibar rest must start at be"
"ginning of bar!", (ftnlen)128, (ftnlen)45);
stop1_();
} else if (a1ll_2.iv == 1 && c1omnotes_1.ibarmbr > 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Multibar rest only OK at one t"
"ime per block!", (ftnlen)128, (ftnlen)44);
stop1_();
}
/* For some purposes, pretend its one bar only */
a1ll_2.nodur[a1ll_2.iv + a1ll_2.nnl[a1ll_2.iv - 1] * 24 - 25] =
a1ll_2.lenbar;
c1omnotes_1.ibarmbr = a1ll_2.nbars + 1;
c1omnotes_1.mbrest = 0;
/* 20 call g1etchar(lineq,iccount,durq) */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected an integer "
"after \"rm\"!", (ftnlen)128, (ftnlen)31);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
c1omnotes_1.mbrest = i_nint(&fnum);
--a1ll_2.iccount;
/* if (ichar(durq).ge.48.and.ichar(durq).le.57) then */
/* mbrest = 10*mbrest+ichar(durq)-48 */
/* go to 20 */
/* end if */
if (a1ll_2.nv > 1) {
if (a1ll_2.iv == 1) {
comkeys_1.mbrestsav = c1omnotes_1.mbrest;
} else {
if (c1omnotes_1.mbrest != comkeys_1.mbrestsav) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must enter s"
"ame multi-bar rest in every voice!", (ftnlen)
128, (ftnlen)46);
stop1_();
}
}
/* Zero out mbrestsav so can check at end of input block whether */
/* all voices have one */
if (a1ll_2.iv == a1ll_2.nv) {
comkeys_1.mbrestsav = 0;
}
}
if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af"
"ter \"rm\"!", (ftnlen)128, (ftnlen)29);
stop1_();
}
} else if (*(unsigned char *)durq == '.') {
/* Dotted pattern. Close out note. Mult time by 3/4. */
/* Set time for next note to 1/4. Start the note. */
idotform = 1;
} else if (*(unsigned char *)durq == ',') {
idotform = 3;
/* Now flow to duration setting, as if durq=' ' */
} else if (i_indx("oL", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Suppress full bar rest, or look left for height */
if (*(unsigned char *)charq != 'r') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",\"L\" options "
"only legal for rest, not note!", (ftnlen)128, (ftnlen)
46);
stop1_();
}
goto L2;
} else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double note for xtup. Must check here in case "D" or "F" came before "x" or on */
/* last note of xtup. Need to flag it in pmxa since affects horiz. spacing. */
c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24
- 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[
c1ommvl_1.ivx - 1] * 24 - 25],18);
goto L2;
} else if (*(unsigned char *)durq == 'A') {
/* Main note accidental option */
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("o+-<>", durq, (ftnlen)5, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",+\",\"-\",\""
"<\",\">\" are the only legal options here!", (ftnlen)
128, (ftnlen)51);
stop1_();
}
/* Need more stuff here */
if (*(unsigned char *)durq != 'o') {
/* Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will */
/* proceed to number input checking */
--a1ll_2.iccount;
}
goto L2;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character!", (
ftnlen)128, (ftnlen)18);
s_wsle(&io___618);
do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11);
i__1 = *(unsigned char *)durq;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
stop1_();
}
/* End of block for note options. */
/* Set the duration */
if (idotform > 0) {
if (idotform == 1) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, (
ftnlen)1) * 3 / 2;
} else if (idotform == 2) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[
c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 3;
} else if (idotform == 3) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, (
ftnlen)1);
} else if (idotform == 4) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[
c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 2;
}
} else if (c1omnotes_1.ibarmbr != a1ll_2.nbars + 1 && ! fulbrp) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 -
25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, (ftnlen)1);
/* Check for double dot */
if (c1omnotes_1.iddot == 1) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[
c1ommvl_1.ivx - 1] * 24 - 25] * 7 / 6;
c1omnotes_1.iddot = 0;
}
} else if (fulbrp) {
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 -
25] = a1ll_2.lenbar;
/* Use a one-line function to set nnodur. It gives inverse of ifnodur. */
i__1 = (integer) (log(a1ll_2.lenbar + .1f) / .69315f) + 48;
chax_(ch__2, (ftnlen)1, &i__1);
c1omnotes_1.nnodur = i_indx("62514x0x37", ch__2, (ftnlen)10, (
ftnlen)1) - 1;
fulbrp = FALSE_;
}
a1ll_2.rest[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25] =
*(unsigned char *)charq == 'r';
/* If inside forced beam, check if note is beamable */
if (c1omget_1.fbon) {
if (a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] < 16) {
goto L120;
}
if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 1) {
if (a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[c1ommvl_1.ivx -
1] - 1) * 24 - 25] == 0) {
goto L120;
}
}
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Unbeamable thing in forc"
"ed beam!", (ftnlen)128, (ftnlen)32);
stop1_();
}
L120:
/* Get number of prior bars for later check on whether note spans bar line */
nbb4 = a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar;
a1ll_2.itsofar[c1ommvl_1.ivx - 1] += a1ll_2.nodur[c1ommvl_1.ivx +
a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25];
if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] % a1ll_2.lenbar == 0) {
++a1ll_2.nbars;
if (comkeys_1.shifton) {
comkeys_1.barend = TRUE_;
}
/* Will check barend when 1st note of next bar is entered. */
if (a1ll_2.nbars > 15) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot have more tha"
"n 15 bars in an input block!", (ftnlen)128, (ftnlen)
48);
stop1_();
}
a1ll_2.nib[c1ommvl_1.ivx + a1ll_2.nbars * 24 - 25] = a1ll_2.nnl[
c1ommvl_1.ivx - 1];
if (a1ll_2.firstline && a1ll_2.lenbar != a1ll_2.lenbr1) {
/* Just finished the pickup bar for this voice. */
if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] != a1ll_2.lenbr0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Pickup bar lengt"
"h disagrees with mtrnum0!", (ftnlen)128, (ftnlen)
41);
stop1_();
}
a1ll_2.lenbar = a1ll_2.lenbr1;
a1ll_2.itsofar[c1ommvl_1.ivx - 1] = 0;
}
} else if (comkeys_1.barend) {
if (comkeys_1.shifton) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar ended with user-"
"defined shift still on!", (ftnlen)128, (ftnlen)43);
stop1_();
}
comkeys_1.barend = FALSE_;
} else if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar > nbb4) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &i__1, &i__4, "This note spans a bar line!", (
ftnlen)128, (ftnlen)27);
stop1_();
}
if (idotform == 1 || idotform == 3) {
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("abcedfgr", charq, (ftnlen)8, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected note name o"
"r \"r\" here!", (ftnlen)128, (ftnlen)31);
stop1_();
}
++idotform;
numnum = 1;
goto L28;
}
/* End of sub block for note-rest */
} else if (*(unsigned char *)charq == 'z') {
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected chord note name"
" here!", (ftnlen)128, (ftnlen)30);
stop1_();
}
L25:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
/* if (index('dre12345678',durq) .gt. 0) then */
if (i_indx("dre12345678c", durq, (ftnlen)12, (ftnlen)1) > 0) {
goto L25;
} else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */
/* MUST come right after "f,s,n" */
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1)
== 0) {
++a1ll_2.iccount;
}
goto L25;
} else if (*(unsigned char *)durq == 'A') {
i__1 = a1ll_2.iccount - 2;
if (i_indx("fsn", lineq + i__1, (ftnlen)3, a1ll_2.iccount - 1 -
i__1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n\" before \""
"A\" in chord note!", (ftnlen)128, (ftnlen)43);
stop1_();
}
goto L25;
} else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) {
i__1 = a1ll_2.iccount - 2;
if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 -
i__1) == 0) {
/* if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems */
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n,A\" before"
" \"<\" or \">\"!", (ftnlen)128, (ftnlen)38);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("1234567890.", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Expected a number to start her"
"e for accidental shift!", (ftnlen)128, (ftnlen)53);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
goto L25;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
i__1 = a1ll_2.iccount;
if (i_indx("1234567890.", lineq + i__1, (ftnlen)11,
a1ll_2.iccount + 1 - i__1) == 0) {
goto L25;
}
/* Number or '.' (durq) follows +/- . Get it. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
i__1 = a1ll_2.iccount;
if (*(unsigned char *)durq == '.' && i_indx("1234567890", lineq +
i__1, (ftnlen)10, a1ll_2.iccount + 1 - i__1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "\".\" here must be followed by"
" a digit!", (ftnlen)128, (ftnlen)37);
stop1_();
} else /* if(complicated condition) */ {
i__1 = a1ll_2.iccount - 3;
if (i_indx("sfndA", lineq + i__1, (ftnlen)5, a1ll_2.iccount -
2 - i__1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Number after +/- must foll"
"ow \"d,s,f,n,A\"!", (ftnlen)128, (ftnlen)41);
stop1_();
}
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
--a1ll_2.iccount;
goto L25;
}
/* 2nd +/- */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '.') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
}
if (i_indx("1234567890", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Expected a number here!", (
ftnlen)128, (ftnlen)23);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
goto L25;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in cho"
"rd note!", (ftnlen)128, (ftnlen)32);
stop1_();
}
} else if (*(unsigned char *)charq == 'G') {
ngr = 1;
L9:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) {
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
ngr = i_nint(&fnum);
--a1ll_2.iccount;
goto L9;
} else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1) > 0) {
goto L9;
} else if (*(unsigned char *)charq == 'm') {
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "A digit less than 5 "
"must follow \"m\" in a grace note!", (ftnlen)128, (
ftnlen)52);
stop1_();
}
goto L9;
} else if (*(unsigned char *)charq == 'X') {
/* Space before main note */
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen)1) > 0) {
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
goto L9;
} else {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "A number must foll"
"ow \"X\" in a grace note!", (ftnlen)128, (ftnlen)41);
stop1_();
}
}
/* At this point, charq is first note name in rest (grace?) */
i__1 = ngr;
for (igr = 1; igr <= i__1; ++igr) {
numnum = 0;
if (igr > 1) {
L55:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)charq == ' ') {
goto L55;
}
}
if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "In grace, expected"
" \"a\"-\"g\"!", (ftnlen)128, (ftnlen)27);
stop1_();
}
L18:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq != ' ') {
if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1) > 0) {
if (numnum == 1) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Only one of"
" \"+-1234567\" allowed here in grace!", (
ftnlen)128, (ftnlen)46);
stop1_();
}
numnum = 1;
goto L18;
/* else if (index('nfs',charq) .gt. 0) then */
} else if (i_indx("+-nfs", charq, (ftnlen)5, (ftnlen)1) > 0) {
goto L18;
}
/* Digits are possible octave numbers */
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal character af"
"ter note name in grace!", (ftnlen)128, (ftnlen)43);
stop1_();
}
/* L19: */
}
} else /* if(complicated condition) */ {
chax_(ch__2, (ftnlen)1, &c__92);
if (*(unsigned char *)charq == *(unsigned char *)&ch__2[0]) {
chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128);
if (literr > 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, literq + (literr - 1) *
51, (ftnlen)128, (ftnlen)51);
stop1_();
}
} else if (*(unsigned char *)charq == 'o') {
/* Ornament on non-xtup note. "o" symbol must come AFTER the affected note */
if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\" must be in sam"
"e input block, after affected note!", (ftnlen)128, (
ftnlen)53);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1);
if (i_indx("(stmgx+Tupf._)e:>^bc", dumq, (ftnlen)20, (ftnlen)1) ==
0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal ornament!", (
ftnlen)128, (ftnlen)17);
stop1_();
}
if (*(unsigned char *)dumq == ':') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)dumq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected blank a"
"fter \"o:\"!", (ftnlen)128, (ftnlen)26);
stop1_();
} else if (! comkeys_1.ornrpt) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Turned off repeated orname"
"nts before they were on!", (ftnlen)128, (ftnlen)
50);
stop1_();
}
comkeys_1.ornrpt = FALSE_;
} else if (*(unsigned char *)dumq == 'g') {
if (c1omget_1.issegno) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Sorry, only one"
" \"segno\" per input block!", (ftnlen)128, (
ftnlen)40);
stop1_();
} else if (c1ommvl_1.ivx != 1) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "segno can only b"
"e in voice 1!", (ftnlen)128, (ftnlen)29);
stop1_();
}
c1omget_1.issegno = TRUE_;
L12:
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)dumq == '-' || *(unsigned char *)dumq >=
48 && *(unsigned char *)dumq <= 58) {
goto L12;
}
if (*(unsigned char *)dumq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r in segno ornament symbol!", (ftnlen)128, (
ftnlen)43);
stop1_();
}
} else if (*(unsigned char *)dumq == 'T') {
/* Trill. may be followed by 't' and/or number. read 'til blank */
L22:
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)dumq == ':') {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected bla"
"nk after \":\"!", (ftnlen)128, (ftnlen)25);
stop1_();
}
goto L32;
} else if (*(unsigned char *)dumq != ' ') {
goto L22;
}
} else if (*(unsigned char *)dumq == 'f') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (i_indx(" d+-:", dumq, (ftnlen)5, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r after \"f\" in fermata ornament symbol!", (
ftnlen)128, (ftnlen)55);
stop1_();
}
if (*(unsigned char *)dumq == 'd') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
}
if (*(unsigned char *)dumq == ':') {
goto L32;
}
} else if (*(unsigned char *)dumq == 'e') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r after \"e\" in edit. accid. symbol!", (ftnlen)
128, (ftnlen)51);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)dumq == '?') {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
}
} else {
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
}
if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in"
" ornament symbol!", (ftnlen)128, (ftnlen)37);
stop1_();
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
i__1 = a1ll_2.iccount;
if (i_indx("0123456789", lineq + i__1, (ftnlen)10,
a1ll_2.iccount + 1 - i__1) == 0) {
i__1 = a1ll_2.iccount + 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "There should be an integer"
" here!", (ftnlen)128, (ftnlen)32);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ':') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot shift AND"
" repeat an ornament!", (ftnlen)128, (ftnlen)36);
stop1_();
}
/* 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
i__1 = a1ll_2.iccount;
if (i_indx(".0123456789", lineq + i__1, (ftnlen)11,
a1ll_2.iccount + 1 - i__1) == 0) {
i__1 = a1ll_2.iccount + 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "There should be a numb"
"er here!", (ftnlen)128, (ftnlen)30);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128,
(ftnlen)1);
}
}
L32:
if (*(unsigned char *)dumq == ':') {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\":\" must be fo"
"llowed by blank in \"o: \"!", (ftnlen)128, (
ftnlen)39);
stop1_();
} else if (comkeys_1.ornrpt) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on repeat"
"ed ornaments but already on!", (ftnlen)128, (
ftnlen)44);
stop1_();
}
comkeys_1.ornrpt = TRUE_;
}
} else if (i_indx("st(){}", charq, (ftnlen)6, (ftnlen)1) > 0) {
numint = 0;
iposn = 0;
L8:
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1);
++iposn;
if (*(unsigned char *)charq == 't' && *(unsigned char *)dumq ==
't') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot use \"t\" as "
"an option on a tie!", (ftnlen)128, (ftnlen)37);
stop1_();
}
if (i_indx("udltb+-fnhHps ", dumq, (ftnlen)14, (ftnlen)1) == 0) {
/* Check for explicit ID code. */
ic = *(unsigned char *)dumq;
if (ic < 48 || ic > 57 && ic < 65 || ic > 90) {
/* Not 0-9 or A-Z, so exit */
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r in slur symbol!", (ftnlen)128, (ftnlen)33);
stop1_();
} else {
/* It is a possible ID code. Right place? */
if (iposn != 1) {
/* Slur ID is not 2nd! */
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID must"
" be second character in slur symbol!", (
ftnlen)128, (ftnlen)48);
stop1_();
} else if (*(unsigned char *)charq == 't' &&
comslur_1.fontslur) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID not "
"allowed on non-postscript tie!", (ftnlen)128,
(ftnlen)42);
stop1_();
}
}
/* Slur ID is OK. Note it cannot be "H" at this point.. */
goto L8;
} else if (*(unsigned char *)dumq == 'H') {
if (iposn == 1) {
goto L8;
}
/* "H" is NOT an ID code. */
if (! comslur_1.fontslur && *(unsigned char *)charq == 't') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape p"
"ostscript ties this way!", (ftnlen)128, (ftnlen)
40);
stop1_();
}
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) == 0) {
++a1ll_2.iccount;
++iposn;
}
goto L8;
} else if (i_indx("fh", dumq, (ftnlen)2, (ftnlen)1) > 0 && !
comslur_1.fontslur && *(unsigned char *)charq == 't') {
/* 3/9/03 Can't reshape postscript tie. */
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape posts"
"cript ties this way!", (ftnlen)128, (ftnlen)40);
stop1_();
} else if (*(unsigned char *)dumq == 'p') {
/* local change in postscript slur/tie adjustment default */
if (comslur_1.fontslur) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must use postscr"
"ipt slurs (\"Ap\") to use this option!", (ftnlen)
128, (ftnlen)52);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"+\" o"
"r \"-\" here!", (ftnlen)128, (ftnlen)25);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"s\" o"
"r \"t\" here!", (ftnlen)128, (ftnlen)25);
stop1_();
}
iposn += 2;
goto L8;
}
if (i_indx("udltbfnh", dumq, (ftnlen)8, (ftnlen)1) > 0) {
goto L8;
} else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
++numint;
if (comslur_1.fontslur && *(unsigned char *)charq == 't') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+|-\" for slur"
" height only allowed in \"s\"-slurs!", (ftnlen)
128, (ftnlen)48);
stop1_();
}
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
if (numint == 1) {
if (i_nint(&fnum) > 30) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Magnitude of slur heig"
"ht adjustment cannot exceed 30!", (ftnlen)128,
(ftnlen)53);
stop1_();
}
} else if (numint == 2) {
if (dabs(fnum) > 6.3f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must "
"be in range (-6.3,6.3)!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
} else {
/* Third signed integer, must be a midslur or curve spec. */
if (dabs(fnum) > 31.f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Slur midheight must be"
" in the range (-31,31)!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
if (*(unsigned char *)durq == ':') {
/* Expecting curve parameters. Get two numbers */
for (i__ = 1; i__ <= 2; ++i__) {
++a1ll_2.iccount;
fnum = (real) (*(unsigned char *)&lineq[
a1ll_2.iccount - 1] - 48);
if ((r__1 = fnum - 3.5f, dabs(r__1)) > 3.6f) {
i__1 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur"
" curve parameter must be in range (0"
",7)!", (ftnlen)128, (ftnlen)44);
stop1_();
}
/* L41: */
}
++a1ll_2.iccount;
}
}
--a1ll_2.iccount;
goto L8;
} else if (*(unsigned char *)dumq == 's') {
/* What follows should be one or two signed numbers for adjustment of line break */
/* slur, end of 1st segment or start of second. */
if (comslur_1.fontslur) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "May not use line"
"break slur options with font-based slurs!", (
ftnlen)128, (ftnlen)57);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)
1);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "This character m"
"ust be \"+\" or \"-\"!", (ftnlen)128, (ftnlen)34);
stop1_();
}
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, (
ftnlen)1);
if (i_nint(&fnum) > 30) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Magnitude of slur height a"
"djustment cannot exceed 30!", (ftnlen)128, (
ftnlen)53);
stop1_();
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128,
(ftnlen)1);
if (dabs(fnum) > 6.3f) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must "
"be in range (-6.3,6.3)!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
}
--a1ll_2.iccount;
goto L8;
} else if (*(unsigned char *)dumq == 'H' && iposn > 1) {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) == 0) {
++a1ll_2.iccount;
}
goto L8;
}
} else if (*(unsigned char *)charq == '?') {
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ' ') {
--a1ll_2.iccount;
} else {
if (*(unsigned char *)durq != '-') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting \"-\"!",
(ftnlen)128, (ftnlen)14);
stop1_();
}
getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1)
;
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting number!"
, (ftnlen)128, (ftnlen)17);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
}
} else if (*(unsigned char *)charq >= 48 && *(unsigned char *)charq <=
57 || i_indx("#-nx_", charq, (ftnlen)5, (ftnlen)1) > 0) {
/* We have a figure. Must come AFTER the note it goes under */
if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] == 0 && (! a1ll_2.firstline
|| a1ll_2.lenbr0 == 0 || a1ll_2.lenbar == a1ll_2.lenbr0))
{
/* Figure before first note in block */
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot put figure be"
"fore first note in block!", (ftnlen)128, (ftnlen)45);
stop1_();
}
if (*(unsigned char *)charq == 'x') {
indxb = i_indx(lineq + (a1ll_2.iccount - 1), " ", 128 - (
a1ll_2.iccount - 1), (ftnlen)1);
if (indxb < 5) {
i__1 = a1ll_2.iccount + indxb - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Cannot have a blank here i"
"n floating figure!", (ftnlen)128, (ftnlen)44);
stop1_();
}
}
if (compage_1.usefig) {
*ifig = 1;
}
L5:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx(" 0123456789#-nx_.:+s", charq, (ftnlen)20, (ftnlen)1)
== 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in"
" figure!", (ftnlen)128, (ftnlen)28);
stop1_();
} else if (*(unsigned char *)charq == '+') {
/* vertical offset, must be integer, then blank */
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)
1);
if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Integer for vert"
"ical offset expected here!", (ftnlen)128, (ftnlen)
42);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, charq, &fnum, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)charq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Vertical offset "
"must terminate figure!", (ftnlen)128, (ftnlen)38);
stop1_();
}
--a1ll_2.iccount;
goto L5;
} else if (*(unsigned char *)charq == 's') {
comligfont_1.isligfont = TRUE_;
}
if (*(unsigned char *)charq != ' ') {
goto L5;
}
} else if (*(unsigned char *)charq == '[') {
if (c1omget_1.fbon) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Started forced beam "
"while another was open!", (ftnlen)128, (ftnlen)43);
stop1_();
}
c1omget_1.fbon = TRUE_;
L17:
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("uljhf:", charq, (ftnlen)6, (ftnlen)1) > 0) {
goto L17;
} else if (i_indx("+-", charq, (ftnlen)2, (ftnlen)1) > 0) {
++a1ll_2.iccount;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
--a1ll_2.iccount;
goto L17;
} else if (*(unsigned char *)charq == 'm') {
/* Forced multiplicity, next char should be 1-4 */
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)
1);
if (i_indx("1234", charq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced multiplic"
"ity for a beam must be 1, 2, 3, or 4!", (ftnlen)
128, (ftnlen)53);
stop1_();
}
goto L17;
} else if (*(unsigned char *)charq != ' ') {
if (i_indx("0123456789", charq, (ftnlen)10, (ftnlen)1) > 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "After \"[\", dig"
"its must now be preceeded by \"+\" or \"-\"!", (
ftnlen)128, (ftnlen)54);
s_wsle(&io___621);
do_lio(&c__9, &c__1, "You will have to edit older source"
"s to meet this rqmt,", (ftnlen)54);
e_wsle();
s_wsle(&io___622);
do_lio(&c__9, &c__1, "but it was needed to allow 2-digit"
" height adjustments.", (ftnlen)54);
e_wsle();
s_wsle(&io___623);
do_lio(&c__9, &c__1, "Sorry for the inconvenience. --Th"
"e Management", (ftnlen)46);
e_wsle();
} else {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r after [!", (ftnlen)128, (ftnlen)26);
}
stop1_();
}
} else if (*(unsigned char *)charq == ']') {
if (! c1omget_1.fbon) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced beam stop wit"
"h no corresponding start!", (ftnlen)128, (ftnlen)45);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == '-') {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, "[ ", a1ll_2.iccount + 2 - i__1, (
ftnlen)2) != 0) {
i__1 = a1ll_2.iccount + 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Only sequence allowed here"
" is \"[ \"!", (ftnlen)128, (ftnlen)35);
stop1_();
} else {
a1ll_2.iccount += 2;
}
} else if (*(unsigned char *)charq == '[') {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) != 0) {
i__1 = a1ll_2.iccount + 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "This character must be a b"
"lank!", (ftnlen)128, (ftnlen)31);
stop1_();
}
} else {
/* Forced beam is really ending */
c1omget_1.fbon = FALSE_;
if (*(unsigned char *)charq == 'j') {
i__1 = a1ll_2.iccount;
if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, (
ftnlen)1) != 0) {
i__1 = a1ll_2.iccount + 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "This character must be"
" a blank!", (ftnlen)128, (ftnlen)31);
stop1_();
}
} else if (*(unsigned char *)charq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"]\" must be fo"
"llowed by blank, \"j\", \"-\", or \"[\"!", (
ftnlen)128, (ftnlen)48);
stop1_();
}
}
} else if (*(unsigned char *)charq == 'D') {
/* Dynamic mark */
if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"D\" must not come "
"before any notes have been entered!", (ftnlen)128, (
ftnlen)53);
stop1_();
}
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
checkdyn_(lineq, &a1ll_2.iccount, &i__1, (ftnlen)128);
} else if (i_indx("lhw", charq, (ftnlen)3, (ftnlen)1) > 0) {
/* Save position for later check */
icclhw = a1ll_2.iccount;
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789.+- ", durq, (ftnlen)14, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af"
"ter \"l\", \"w\", or \"h\"!", (ftnlen)128, (ftnlen)41)
;
stop1_();
}
c1omget_1.isheadr = c1omget_1.isheadr || *(unsigned char *)charq
== 'h';
if (i_indx(" +-", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* There is a header (or lower string?) */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* User-defined vert offset (\internote). */
if (*(unsigned char *)charq != 'h') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+\" or \""
"-\" not permitted here!", (ftnlen)128, (
ftnlen)30);
stop1_();
}
/* Have "h" followed by +/- . Check for digit. */
/* Can blow durq since not using fnum for now, but... */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0)
{
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must b"
"e a digit here!", (ftnlen)128, (ftnlen)27);
stop1_();
}
/* Have "h" followed by +/- followed by a digit. No need to get the number. */
/* call readnum(lineq,iccount,durq,fnum) */
}
if (*(unsigned char *)charq != 'w') {
/* Header or lower string. */
if (icclhw != 1) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "\"h\" or \"l\" must be"
" first character in line!", (ftnlen)128, (
ftnlen)43);
stop1_();
}
/* Read past the next line, which has the string. */
read10_(charq, &c1omget_1.lastchar, (ftnlen)1);
++c1omget_1.nline;
a1ll_2.iccount = 128;
} else {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol \"w\" (wi"
"dth) must be followed by a digit!", (ftnlen)128, (
ftnlen)47);
stop1_();
}
} else {
/* Height or width change spec. Check if at start of piece. */
if (c1omnotes_1.ibarcnt > 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol must go a"
"t top of first input block!", (ftnlen)128, (
ftnlen)43);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &dimen, (ftnlen)128, (
ftnlen)1);
/* Check units. Convert to points */
if (*(unsigned char *)durq == ' ' || *(unsigned char *)durq ==
'p') {
dimen += .5f;
} else if (*(unsigned char *)durq == 'i') {
dimen = dimen * 72 + .5f;
} else if (*(unsigned char *)durq == 'm') {
dimen = dimen / 25.4f * 72 + .5f;
} else {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal unit; mu"
"st be \"p\",\"i\",or\"m\"!", (ftnlen)128, (ftnlen)
36);
stop1_();
}
if (*(unsigned char *)charq == 'h') {
compage_1.ptheight = (real) ((integer) dimen);
} else {
compage_1.widthpt = (real) ((integer) dimen);
}
}
} else if (*(unsigned char *)charq == 'm') {
/* Time signature change. Only allow at beginning of block. */
/* mtrnuml, mtrdenl (logical) and p (printable) will be input. */
/* mtrnuml=0 initially. (In common) */
/* Check whether at beginning of a block */
if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Meter change only OK"
" in voice 1, at start of block!", (ftnlen)128, (
ftnlen)51);
s_wsle(&io___626);
do_lio(&c__9, &c__1, "voice number is", (ftnlen)15);
do_lio(&c__3, &c__1, (char *)&c1ommvl_1.ivx, (ftnlen)sizeof(
integer));
e_wsle();
stop1_();
}
a1ll_2.newmeter = TRUE_;
readmeter_(lineq, &a1ll_2.iccount, &a1ll_2.mtrnuml, &mtrdenl, (
ftnlen)128);
if (a1ll_2.mtrnuml == 0) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Digit 0 not allowed here!", (
ftnlen)128, (ftnlen)25);
stop1_();
/* else if (mtrdenl .eq. 1) then */
/* c */
/* c Kluge!!! */
/* c */
/* mtrdenl = 2 */
/* mtrnuml = 2*mtrnuml */
}
readmeter_(lineq, &a1ll_2.iccount, &mtrnmp, &mtrdnp, (ftnlen)128);
/* Read past printed time signature; not used in pmxa. */
lenbeat = i1fnodur_(&mtrdenl, "x", (ftnlen)1);
lenmult = 1;
if (mtrdenl == 2) {
lenbeat = 16;
lenmult = 2;
}
a1ll_2.lenbar = lenmult * a1ll_2.mtrnuml * lenbeat;
a1ll_2.mtrnuml = 0;
} else if (*(unsigned char *)charq == 'C') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (! (i_indx("tsmanrbf", durq, (ftnlen)8, (ftnlen)1) > 0 || *(
unsigned char *)durq >= 48 && *(unsigned char *)durq <=
55)) {
/* * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then */
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have t,s,m,a,n,"
"r,b,f or 1-7 after C!", (ftnlen)128, (ftnlen)41);
/* * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') */
stop1_();
}
c1omnotes_1.gotclef = TRUE_;
} else if (*(unsigned char *)charq == 'R') {
if (c1ommvl_1.ivx != 1) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Repeats can only go "
"in voice 1!", (ftnlen)128, (ftnlen)31);
stop1_();
}
L10:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("lrdDbz", durq, (ftnlen)6, (ftnlen)1) > 0) {
goto L10;
}
if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af"
"ter \"R\" (repeat/double bar)!", (ftnlen)128, (ftnlen)
48);
stop1_();
}
} else if (*(unsigned char *)charq == 'V') {
/* Ending */
if (a1ll_2.iv != 1) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Voltas are only allo"
"wed in voice #1!", (ftnlen)128, (ftnlen)36);
stop1_();
} else if (c1omget_1.isvolt) {
s_wsle(&io___632);
e_wsle();
s_wsle(&io___633);
do_lio(&c__9, &c__1, "*******WARNING********", (ftnlen)22);
e_wsle();
s_wsfe(&io___634);
do_fio(&c__1, "*******WARNING********", (ftnlen)22);
e_wsfe();
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "There is more than o"
"ne volta in this input block.!", (ftnlen)128, (ftnlen)
50);
s_wsle(&io___635);
do_lio(&c__9, &c__1, "This may work in a score, but WILL NOT"
" work in parts.", (ftnlen)53);
e_wsle();
s_wsle(&io___636);
do_lio(&c__9, &c__1, "Safest to have only 1 volta per block,"
" at the start of the block", (ftnlen)64);
e_wsle();
s_wsfe(&io___637);
do_fio(&c__1, "This may work in a score, but WILL NOT work i"
"n parts.", (ftnlen)53);
e_wsfe();
s_wsfe(&io___638);
do_fio(&c__1, "Safest to have only 1 volta per block, at the"
" start of the block", (ftnlen)64);
e_wsfe();
}
c1omget_1.isvolt = TRUE_;
lvoltxt = 0;
L11:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
goto L11;
}
} else if (*(unsigned char *)charq == 'B') {
} else if (*(unsigned char *)charq == 'P') {
if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only allowed at begi"
"nning of block!", (ftnlen)128, (ftnlen)35);
stop1_();
}
L16:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'l' || *(unsigned char *)durq ==
'r' || *(unsigned char *)durq >= 48 && *(unsigned char *)
durq <= 57) {
goto L16;
}
if (*(unsigned char *)durq == 'c') {
/* Expect a centered name, and it has to be last option */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)durq == '"') {
/* Quoted name, go to next quote mark */
for (++a1ll_2.iccount; a1ll_2.iccount <= 127;
++a1ll_2.iccount) {
if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] ==
'"') {
goto L36;
}
/* L35: */
}
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Missing close qu"
"ote after page number command (P)!", (ftnlen)128,
(ftnlen)50);
stop1_();
L36:
;
} else if (*(unsigned char *)durq != ' ') {
/* Space-delimited name, look for next blank */
for (++a1ll_2.iccount; a1ll_2.iccount <= 127;
++a1ll_2.iccount) {
if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] ==
' ') {
goto L38;
}
/* L37: */
}
L38:
;
}
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only \"l\",\"r\",\""
"c\" or digit allowed after \"P\"!", (ftnlen)128, (
ftnlen)44);
stop1_();
}
} else if (*(unsigned char *)charq == 'W') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx(".0123456789", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected a number to"
" start here!", (ftnlen)128, (ftnlen)32);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &c1omnotes_1.wminnh[
c1omnotes_1.ibarcnt + a1ll_2.nbars], (ftnlen)128, (ftnlen)
1);
} else if (*(unsigned char *)charq == 'T') {
/* Titles */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("itc", durq, (ftnlen)3, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must put \"i\", \""
"t\", or \"c\" after \"T\"!", (ftnlen)128, (ftnlen)36);
stop1_();
}
i__1 = i_indx("itc", durq, (ftnlen)3, (ftnlen)1) - 1;
c1omget_1.ihead += pow_ii(&c__2, &i__1);
/* Maybe a number after 'Tt', but ignore here. Read past string on next line. */
read10_(charq, &c1omget_1.lastchar, (ftnlen)1);
++c1omget_1.nline;
a1ll_2.iccount = 128;
} else if (*(unsigned char *)charq == 'A') {
L27:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("rbsdeK", durq, (ftnlen)6, (ftnlen)1) > 0) {
goto L27;
} else if (*(unsigned char *)durq == 'v') {
if (c1omnotes_1.ibarcnt == 0) {
comnvst_1.novshrinktop = TRUE_;
}
goto L27;
} else if (*(unsigned char *)durq == 'a') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "After \"Aa\", ne"
"ed decimal number!", (ftnlen)128, (ftnlen)32);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &c1ommvl_1.fbar, (
ftnlen)128, (ftnlen)1);
--a1ll_2.iccount;
goto L27;
} else if (*(unsigned char *)durq == 'i') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
/* Local interstaff correction. Set to -1. if not specifiec, or after use, */
/* or anytime except at top, since pmxb handles all times except at top. */
readnum_(lineq, &a1ll_2.iccount, durq, &tintstf, (ftnlen)128,
(ftnlen)1);
if (c1omnotes_1.ibarcnt == 0) {
compage_1.fintstf = tintstf;
}
--a1ll_2.iccount;
goto L27;
} else if (*(unsigned char *)durq == 'I') {
/* Global interstaff correction. Use in place of fintstf if fintstf<0 */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
readnum_(lineq, &a1ll_2.iccount, durq, &compage_1.gintstf, (
ftnlen)128, (ftnlen)1);
--a1ll_2.iccount;
goto L27;
} else if (*(unsigned char *)durq == 'o') {
*optimize = TRUE_;
goto L27;
} else if (*(unsigned char *)durq == 'S') {
/* 130324 */
/* do 50 iiv = 1 , nv */
i__1 = comkeys_1.noinst;
for (iiv = 1; iiv <= i__1; ++iiv) {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("-0st", durq, (ftnlen)4, (ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "After \"AS\""
", need nv instances of \"s,t,-,0\"!", (ftnlen)
128, (ftnlen)43);
stop1_();
}
if (*(unsigned char *)durq == '-' || *(unsigned char *)
durq == 's') {
comsize_1.isize[iiv - 1] = 1;
} else if (*(unsigned char *)durq == 't') {
comsize_1.isize[iiv - 1] = 2;
}
/* L50: */
}
goto L27;
} else if (*(unsigned char *)durq == 'p') {
comslur_1.fontslur = FALSE_;
L42:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Characters to change defaults for ps slurs */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("shtc", durq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only letters"
" allowed here are \"s\",\"h\",\"t\",\"c\"!", (
ftnlen)128, (ftnlen)46);
stop1_();
}
/* Now check for another default modifier */
goto L42;
} else if (i_indx("lh", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Flags for optional linebreak ties or header specials */
goto L42;
} else {
--a1ll_2.iccount;
}
goto L27;
} else if (*(unsigned char *)durq == 'N') {
/* Override default name for a part file. Must have part number, then */
/* partname in quotes. Must be on line by itself, and start in column 1. */
/* Will only be passed thru to scor2prt. */
if (a1ll_2.iccount != 2) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must star"
"t in column 1!", (ftnlen)128, (ftnlen)28);
stop1_();
}
ndxquote = i_indx(lineq, "\"", (ftnlen)128, (ftnlen)1);
if (ndxquote < 4 || ndxquote > 5 || i_indx("123456789", lineq
+ 2, (ftnlen)9, (ftnlen)1) == 0 || ndxquote == 5 &&
i_indx("012", lineq + 3, (ftnlen)3, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must be f"
"ollowed by inst. #, then quote!", (ftnlen)128, (
ftnlen)45);
stop1_();
}
i__1 = ndxquote;
ndxquote = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1);
if (ndxquote == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "In \"AN\", file "
"name must be in quotes!", (ftnlen)128, (ftnlen)37)
;
stop1_();
}
a1ll_2.iccount = 128;
} else if (*(unsigned char *)durq == 'T') {
comnvst_1.cstuplet = TRUE_;
} else if (*(unsigned char *)durq == 'R') {
/* Get full name of normal include file; must occupy remainder of line */
i__1 = a1ll_2.iccount;
getpmxmod_(&c_false, lineq + i__1, 128 - i__1);
a1ll_2.iccount = 128;
} else if (*(unsigned char *)durq == 'c') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("l4", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only \"l\" or"
" \"4\" is allowed here!", (ftnlen)128, (ftnlen)32)
;
stop1_();
}
if (*(unsigned char *)durq == 'l') {
compage_1.hoffpt = -25.f;
compage_1.voffpt = -45.f;
} else if (*(unsigned char *)durq == '4') {
compage_1.ptheight = 745.f;
compage_1.widthpt = 499.f;
compage_1.hoffpt = -24.f;
compage_1.voffpt = -24.f;
}
goto L27;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "After \"A\" must fol"
"low one of the letters abcdeiINprRsST!", (ftnlen)128,
(ftnlen)56);
s_wsle(&io___643);
do_lio(&c__9, &c__1, "For AS, since ver. 2.7, must only have"
" noinst args.", (ftnlen)51);
e_wsle();
s_wsfe(&io___644);
do_fio(&c__1, "For AS, since ver. 2.7, must only have noinst"
" args.", (ftnlen)51);
e_wsfe();
stop1_();
}
} else if (*(unsigned char *)charq == 'K') {
/* Rules and function of K command */
/* Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is */
/* initial sig, and must be passed to pmxb because it is needed when topfile */
/* is called, which is before the K+n+m command is read in pmxb. Also, we */
/* compute and save ibrkch and newkey for each syst, accounting for key changes, */
/* then adjust fbar to make poenom much more accurate. */
/* Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. */
L77:
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
/* if (index('+-i',durq) .eq. 0) then */
if (i_indx("+-in", durq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"K\" (transpose or "
"key change) must be followed by \"+,-,i,n\"!", (
ftnlen)128, (ftnlen)60);
stop1_();
}
if (*(unsigned char *)durq == 'n') {
goto L77;
}
if (*(unsigned char *)durq != 'i') {
/* Normal key change and/or transposition) */
/* iccount = iccount+1 */
num1 = 44 - *(unsigned char *)durq;
/* num1= +1 or -1 */
ztrans = num1 == -1;
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "1st +/- must be "
"followed by a number!", (ftnlen)128, (ftnlen)37);
stop1_();
}
/* iccount = iccount+1 */
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
num1 = i_nint(&fnum) * num1;
ztrans = ztrans && num1 == 0;
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "1st number aft"
"er \"K\" must be followed by \"+,-\"!", (ftnlen)
128, (ftnlen)47);
stop1_();
}
++a1ll_2.iccount;
num2 = 44 - *(unsigned char *)durq;
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
num2 *= (integer) (fnum + .1f);
if (num1 == 0 && ! ztrans) {
/* Key change, only one per block allowed */
if (comkeys_1.iskchb) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only one key"
" change allowed per input block!", (ftnlen)
128, (ftnlen)44);
stop1_();
}
comkeys_1.iskchb = TRUE_;
++comkeys_1.nkeys;
comkeys_1.kchmid[comkeys_1.nkeys - 1] = a1ll_2.itsofar[
c1ommvl_1.ivx - 1] % a1ll_2.lenbar != 0;
/* Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. */
comkeys_1.ibrkch[comkeys_1.nkeys - 1] =
c1omnotes_1.ibarcnt + a1ll_2.nbars;
if (comkeys_1.kchmid[comkeys_1.nkeys - 1]) {
++comkeys_1.ibrkch[comkeys_1.nkeys - 1];
}
comkeys_1.newkey[comkeys_1.nkeys - 1] = num2 +
comkeys_1.idsig;
/* 130316 */
/* do 43 iinst = 1 , noinst */
commidisig_1.midisig = comkeys_1.newkey[comkeys_1.nkeys -
1];
/* 43 continue */
} else {
/* Transposition */
*fulltrans = TRUE_;
if (c1omnotes_1.ibarcnt > 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Transpositio"
"n must be at top of first input block!", (
ftnlen)128, (ftnlen)50);
stop1_();
}
comkeys_1.isig1 = num2;
comkeys_1.idsig = comkeys_1.isig1 - comkeys_1.newkey[0];
/* idsig is the difference between sig after transposition, and sig in setup. */
/* It may alter # of accid's in key changes if there is transposition. */
}
} else {
/* 110522/110529 */
/* Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] */
/* and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 */
/* so can pass to topfile (via comInstTrans), which is called before getnote. */
/* Otherwise, will store info from getnote. Initialize EarlyTransOn and */
/* LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; */
/* LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really */
/* only needed for instrument-signatures, not transpositions. iTransAmt is */
/* ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for */
/* each staff. */
/* if (fulltrans) then */
/* call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, */
/* * 'Cannot yet combine full and instrument transposition!') */
/* call stop1() */
/* end if */
/* durq='i' */
getitransinfo_(&c_true, &c1omnotes_1.ibarcnt, lineq, &
a1ll_2.iccount, &c1omnotes_1.ibaroff, &a1ll_2.nbars, &
comkeys_1.noinst, &a1ll_2.iv, (ftnlen)128);
}
} else if (*(unsigned char *)charq == '|') {
/* Optional bar symbol */
if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] % a1ll_2.lenbar != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar line marker out "
"of place!", (ftnlen)128, (ftnlen)29);
stop1_();
} else if (comkeys_1.shifton) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar ended with user-"
"defined shift still on!", (ftnlen)128, (ftnlen)43);
stop1_();
}
} else if (*(unsigned char *)charq == '/') {
if (comkeys_1.ornrpt) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "WARNING: Block ended"
" with repeated ornament still on!", (ftnlen)128, (
ftnlen)53);
comkeys_1.ornrpt = FALSE_;
}
if (comkeys_1.stickys) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "WARNING: Block ended"
" with sticky stemshrink still on!", (ftnlen)128, (
ftnlen)53);
comkeys_1.stickys = FALSE_;
}
if (c1omget_1.fbon) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Block ended with for"
"ced beam open!", (ftnlen)128, (ftnlen)34);
stop1_();
} else if (comkeys_1.shifton) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar ended with user-"
"defined shift still on!", (ftnlen)128, (ftnlen)43);
stop1_();
} else if (c1omnotes_1.gotclef) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "May not enter clef a"
"t end of input block!", (ftnlen)128, (ftnlen)41);
stop1_();
}
comkeys_1.barend = FALSE_;
/* Perform time checks */
if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] % a1ll_2.lenbar != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Block duration not d"
"ivisible by lenbar!", (ftnlen)128, (ftnlen)39);
s_wsle(&io___648);
do_lio(&c__9, &c__1, "lenbar is ", (ftnlen)10);
do_lio(&c__3, &c__1, (char *)&a1ll_2.lenbar, (ftnlen)sizeof(
integer));
e_wsle();
stop1_();
} else if (c1ommvl_1.ivx > 1 && a1ll_2.itsofar[c1ommvl_1.ivx - 1]
!= a1ll_2.itsofar[0]) {
s_wsle(&io___649);
e_wsle();
s_wsle(&io___650);
do_lio(&c__9, &c__1, "# of bars in voice 1, current voice:", (
ftnlen)36);
i__1 = a1ll_2.itsofar[0] / a1ll_2.lenbar;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
i__4 = a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar;
do_lio(&c__3, &c__1, (char *)&i__4, (ftnlen)sizeof(integer));
e_wsle();
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Block duration not e"
"qual to voice 1!", (ftnlen)128, (ftnlen)36);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ' ' && a1ll_2.iv == a1ll_2.nv) {
/* End of input block */
*loop = FALSE_;
} else {
/* Start a new voice */
if (a1ll_2.lenbr0 != 0 && a1ll_2.firstline) {
a1ll_2.lenbar = a1ll_2.lenbr0;
}
a1ll_2.nbars = 0;
if (*(unsigned char *)durq == ' ') {
/* New voice is on next staff */
++a1ll_2.iv;
c1ommvl_1.ivx = a1ll_2.iv;
} else {
/* New voice is on same staff. Set up for it */
c1ommvl_1.ivx = a1ll_2.nv + 1;
i__1 = a1ll_2.nv;
for (iiv = 1; iiv <= i__1; ++iiv) {
if (c1ommvl_1.nvmx[iiv - 1] == 2) {
++c1ommvl_1.ivx;
}
/* L23: */
}
if (c1ommvl_1.ivx > 24) {
s_wsfe(&io___651);
do_fio(&c__1, "Cannot have more than", (ftnlen)21);
do_fio(&c__1, (char *)&c__24, (ftnlen)sizeof(integer))
;
do_fio(&c__1, " lines of music at once", (ftnlen)23);
e_wsfe();
stop1_();
}
c1ommvl_1.nvmx[a1ll_2.iv - 1] = 2;
c1ommvl_1.ivmx[a1ll_2.iv + 23] = c1ommvl_1.ivx;
a1ll_2.itsofar[c1ommvl_1.ivx - 1] = 0;
a1ll_2.nnl[c1ommvl_1.ivx - 1] = 0;
for (j = 1; j <= 200; ++j) {
a1ll_2.rest[c1ommvl_1.ivx + j * 24 - 25] = FALSE_;
c1ommvl_1.nacc[c1ommvl_1.ivx + j * 24 - 25] = 0;
/* L24: */
}
/* For midi stuff, record that there is a 2nd line of music in this voice */
if (commidi_1.ismidi) {
commidi_1.twoline[a1ll_2.iv - 1] = TRUE_;
}
}
}
a1ll_2.iccount = 128;
} else if (*(unsigned char *)charq == 'S') {
/* New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. */
if (c1omnotes_1.ibarcnt > 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"S\" can only be in"
" first input block!", (ftnlen)128, (ftnlen)37);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789 ", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "A digit must follow"
" \"S\"!", (ftnlen)128, (ftnlen)24);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnsyst, (ftnlen)128, (
ftnlen)1);
compage_1.nsyst = i_nint(&fnsyst);
L14:
if (*(unsigned char *)durq == 'P') {
/* New npages for parts. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("123456789 ", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have a numb"
"er here!", (ftnlen)128, (ftnlen)24);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnsyst, (ftnlen)128, (
ftnlen)1);
compage_1.npages = i_nint(&fnsyst);
goto L14;
} else if (*(unsigned char *)durq == 'm') {
/* Reset musize (musicsize). */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("123456789 ", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have a numb"
"er here!", (ftnlen)128, (ftnlen)24);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnsyst, (ftnlen)128, (
ftnlen)1);
commus_1.musize = i_nint(&fnsyst);
c1omnotes_1.wheadpt = commus_1.whead20 * commus_1.musize;
goto L14;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character "
"in \"S\" symbol!", (ftnlen)128, (ftnlen)32);
stop1_();
}
} else if (*(unsigned char *)charq == 'L') {
++compage_1.nflb;
compage_1.ibarflb[compage_1.nflb] = c1omnotes_1.ibarcnt +
a1ll_2.nbars + 1;
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Need integer to defi"
"ne forced line break!", (ftnlen)128, (ftnlen)41);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &sysflb, (ftnlen)128, (
ftnlen)1);
compage_1.isysflb[compage_1.nflb] = i_nint(&sysflb);
if (compage_1.nflb > 1) {
/* Check if new number is > prior one */
if (compage_1.isysflb[compage_1.nflb] <= compage_1.isysflb[
compage_1.nflb - 1]) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "You already forced a line "
"break at a later line!", (ftnlen)128, (ftnlen)48);
stop1_();
}
}
if (compage_1.npages == 0) {
s_wsle(&io___655);
e_wsle();
s_wsle(&io___656);
do_lio(&c__9, &c__1, "WARNING! You forced a line break at li"
"ne ", (ftnlen)41);
do_lio(&c__3, &c__1, (char *)&compage_1.isysflb[
compage_1.nflb], (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " but npage = 0. Continue?", (ftnlen)26)
;
e_wsle();
s_rsfe(&io___657);
do_fio(&c__1, charq, (ftnlen)1);
e_rsfe();
if (i_indx("yY", charq, (ftnlen)2, (ftnlen)1) == 0) {
stop1_();
}
} else if (compage_1.isysflb[compage_1.nflb] > compage_1.nsyst) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced line break at"
" line num > nsyst!", (ftnlen)128, (ftnlen)38);
stop1_();
} else if (i_indx(" PM", durq, (ftnlen)3, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have \" \", \""
"P\", or \"M\" here!", (ftnlen)128, (ftnlen)32);
stop1_();
}
if (*(unsigned char *)durq == 'P') {
/* Forced page break here, get page number. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Need integer to "
"define forced page break!", (ftnlen)128, (ftnlen)
41);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
++compage_1.nfpb;
compage_1.ipagfpb[compage_1.nfpb] = i_nint(&fnum);
compage_1.isysfpb[compage_1.nfpb] = compage_1.isysflb[
compage_1.nflb];
if (compage_1.ipagfpb[compage_1.nfpb] > compage_1.npages) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Forced page break at page "
"num > npages!", (ftnlen)128, (ftnlen)39);
stop1_();
} else if (compage_1.nfpb > 1) {
if (compage_1.ipagfpb[compage_1.nfpb] <=
compage_1.ipagfpb[compage_1.nfpb - 1]) {
i__1 = a1ll_2.iccount - 1;
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &i__1, &i__4, "Forced page break numb"
"ers must increase!", (ftnlen)128, (ftnlen)40);
stop1_();
}
}
}
if (i_indx(" M", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in"
" linebreak symbol!", (ftnlen)128, (ftnlen)38);
stop1_();
} else if (*(unsigned char *)durq == 'M') {
++compage_1.nmovbrk;
compage_1.isysmb[compage_1.nmovbrk] = compage_1.isysflb[
compage_1.nflb];
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)
1);
L31:
if (*(unsigned char *)durq == '+') {
/* Vertical spacing, read past number. */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0)
{
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Integer requ"
"ired here!", (ftnlen)128, (ftnlen)22);
stop1_();
}
readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128,
(ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'i') {
/* Change indentation, */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx(".123456789", durq, (ftnlen)10, (ftnlen)1) ==
0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Decimal numb"
"er required here!", (ftnlen)128, (ftnlen)29);
stop1_();
}
/* fracsys was initialized in block data to all 0.'s */
readnum_(lineq, &a1ll_2.iccount, durq, &compage_1.fracsys[
compage_1.nmovbrk - 1], (ftnlen)128, (ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'c') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'r') {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have"
" \"+\" or \"-\" after \"r\" as movement brea"
"k option!", (ftnlen)128, (ftnlen)56);
stop1_();
}
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'n') {
/* Change # of voices. Input ninow, iorig(1...ninow). Will use names, */
/* staves per inst. and clefs corr. to iorig in original list of instruments. */
a1ll_2.nv = 0;
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ':') {
/* Signals a 2-digit number, get next two characters */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (
ftnlen)1);
if (i_indx("12", durq, (ftnlen)2, (ftnlen)1) == 0 ||
i_indx("0123456789", dumq, (ftnlen)10, (
ftnlen)1) == 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
/* Writing concatenation */
i__8[0] = 34, a__3[0] = "Illegal new number of i"
"nstruments ";
i__8[1] = 1, a__3[1] = durq;
i__8[2] = 1, a__3[2] = dumq;
i__8[3] = 19, a__3[3] = " at movement break!";
s_cat(ch__3, a__3, i__8, &c__4, (ftnlen)55);
errmsg_(lineq, &a1ll_2.iccount, &i__1, ch__3, (
ftnlen)128, (ftnlen)55);
stop1_();
}
i__1 = a1ll_2.iccount - 2;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = a1ll_2.iccount - i__1;
ici__1.iciunit = lineq + i__1;
ici__1.icifmt = "(i2)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&ninow, (ftnlen)sizeof(integer))
;
e_rsfi();
} else {
/* durq is a single digit number for noinow */
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) ==
0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
/* Writing concatenation */
i__2[0] = 34, a__1[0] = "Illegal new number of i"
"nstruments ";
i__2[1] = 1, a__1[1] = durq;
i__2[2] = 19, a__1[2] = " at movement break!";
s_cat(ch__4, a__1, i__2, &c__3, (ftnlen)54);
errmsg_(lineq, &a1ll_2.iccount, &i__1, ch__4, (
ftnlen)128, (ftnlen)54);
stop1_();
}
ninow = *(unsigned char *)durq - 48;
}
if (ninow > comkeys_1.noinst) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "New number o"
"f instruments must be <= original!", (ftnlen)
128, (ftnlen)46);
stop1_();
}
i__1 = ninow;
for (iinow = 1; iinow <= i__1; ++iinow) {
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ':') {
/* Signals a 2-digit number */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)
128, (ftnlen)1);
g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)
128, (ftnlen)1);
if (i_indx("12", durq, (ftnlen)2, (ftnlen)1) == 0
|| i_indx("0123456789", dumq, (ftnlen)10,
(ftnlen)1) == 0) {
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
/* Writing concatenation */
i__8[0] = 34, a__3[0] = "Illegal 2-digit ins"
"trument number ";
i__8[1] = 1, a__3[1] = durq;
i__8[2] = 1, a__3[2] = dumq;
i__8[3] = 19, a__3[3] = " at movement break!";
s_cat(ch__3, a__3, i__8, &c__4, (ftnlen)55);
errmsg_(lineq, &a1ll_2.iccount, &i__4, ch__3,
(ftnlen)128, (ftnlen)55);
stop1_();
}
i__4 = a1ll_2.iccount - 2;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = a1ll_2.iccount - i__4;
ici__1.iciunit = lineq + i__4;
ici__1.icifmt = "(i2)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&iorig, (ftnlen)sizeof(
integer));
e_rsfi();
} else {
/* durq is a single digit number for iorig */
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)
1) == 0) {
i__4 = c1omnotes_1.ibarcnt -
c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
/* Writing concatenation */
i__2[0] = 26, a__1[0] = "Illegal instrument "
"number ";
i__2[1] = 1, a__1[1] = durq;
i__2[2] = 19, a__1[2] = " at movement break!";
s_cat(ch__5, a__1, i__2, &c__3, (ftnlen)46);
errmsg_(lineq, &a1ll_2.iccount, &i__4, ch__5,
(ftnlen)128, (ftnlen)46);
stop1_();
}
iorig = *(unsigned char *)durq - 48;
}
if (iorig > comkeys_1.noinst) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "New inst"
"rument number must be <= original noinst!"
, (ftnlen)128, (ftnlen)49);
stop1_();
}
a1ll_2.nv += c1omget_1.nsperi[iorig - 1];
/* L63: */
}
i__1 = a1ll_2.nv;
for (iiv = 1; iiv <= i__1; ++iiv) {
/* Get clef names */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (! (i_indx("tsmanrbf", durq, (ftnlen)8, (ftnlen)1)
> 0 || *(unsigned char *)durq >= 48 && *(
unsigned char *)durq <= 55)) {
i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff
+ a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__4, "Must hav"
"e t,s,m,a,n,r,b,f or 1-7 as clef symbol "
"here!", (ftnlen)128, (ftnlen)53);
stop1_();
}
/* Initialize new voices */
c1ommvl_1.nvmx[iiv - 1] = 1;
c1ommvl_1.ivmx[iiv - 1] = iiv;
a1ll_2.itsofar[iiv - 1] = 0;
a1ll_2.nnl[iiv - 1] = 0;
for (j = 1; j <= 200; ++j) {
a1ll_2.rest[iiv + j * 24 - 25] = FALSE_;
/* L62: */
}
/* L61: */
}
/* Loop back up, this might not be last option in M */
g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (
ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq != ' ') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte"
"r after Movement break symbol!", (ftnlen)128, (
ftnlen)46);
stop1_();
}
if (compage_1.fracsys[compage_1.nmovbrk - 1] < .001f) {
/* Since fracsys was not explicitly set, set it to prior value. */
if (compage_1.nmovbrk == 1) {
compage_1.fracsys[compage_1.nmovbrk - 1] =
c1omget_1.fracindent;
} else {
compage_1.fracsys[compage_1.nmovbrk - 1] =
compage_1.fracsys[compage_1.nmovbrk - 2];
}
}
}
/* Just before exiting if-block for forced line breaks, set counter to use when */
/* dealing with vertical space calcs */
compage_1.nistaff[compage_1.nflb] = a1ll_2.nv - 1;
} else if (*(unsigned char *)charq == 'F') {
compage_1.usefig = FALSE_;
} else if (*(unsigned char *)charq == 'X') {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
g1etx_(lineq, &a1ll_2.iccount, &c_true, &comkeys_1.shifton, &i__1,
&c1omnotes_1.udsp[c1omnotes_1.ibarcnt + a1ll_2.nbars], &
c1omnotes_1.wheadpt, (ftnlen)128);
} else if (*(unsigned char *)charq == 'I') {
/* MIDI settings. */
if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "MIDI stuff only allo"
"wed at start of block!", (ftnlen)128, (ftnlen)42);
stop1_();
}
if (a1ll_2.nv > 15) {
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
a1ll_2.nbars + 1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "Sorry but MIDI does "
"not work with more than 15 voices!", (ftnlen)128, (
ftnlen)54);
stop1_();
}
commidi_1.ismidi = TRUE_;
/* call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, */
getmidi_(&comkeys_1.noinst, lineq, &a1ll_2.iccount, &
c1omnotes_1.ibarcnt, &c1omnotes_1.ibaroff, &a1ll_2.nbars,
&a1ll_2.lenbar, &mtrdenl, &c_true, (ftnlen)128);
} else if (*(unsigned char *)charq == 'M') {
setmac_(lineq, &a1ll_2.iccount, &c1omnotes_1.ibarcnt, &
c1omnotes_1.ibaroff, &a1ll_2.nbars, charq, durq, &
c1ommvl_1.ivx, &c1omget_1.nline, (ftnlen)128, (ftnlen)1, (
ftnlen)1);
} else if (i_indx(",.", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Continued rhythmic shortcut */
idotform = i_indx(". ,", charq, (ftnlen)3, (ftnlen)1);
if (idotform == 1) {
/* Change duration of prior note */
a1ll_2.itsofar[c1ommvl_1.ivx - 1] -= a1ll_2.nodur[
c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 -
25];
a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] *
24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[
c1ommvl_1.ivx - 1] * 24 - 25] * 3 / 2;
a1ll_2.itsofar[c1ommvl_1.ivx - 1] += a1ll_2.nodur[
c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 -
25];
}
++idotform;
numnum = 1;
cdot = TRUE_;
goto L1;
} else {
s_wsle(&io___661);
do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11);
i__1 = *(unsigned char *)charq;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars +
1;
errmsg_(lineq, &a1ll_2.iccount, &i__1, "This character is not al"
"lowed here!", (ftnlen)128, (ftnlen)35);
s_wsle(&io___662);
do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11);
i__1 = *(unsigned char *)charq;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
stop1_();
}
}
return 0;
} /* g1etnote_ */
/* Subroutine */ int g1etset_(integer *nv, integer *noinst, integer *mtrnuml,
integer *mtrdenl, integer *mtrnmp, integer *mtrdnp, real *xmtrnum0,
integer *newkey, integer *npages, integer *nsyst, integer *musize,
logical *bottreb)
{
/* System generated locals */
address a__1[2], a__2[3];
integer i__1, i__2[2], i__3[3];
real r__1;
char ch__1[3], ch__2[1], ch__3[50];
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), do_lio(
integer *, integer *, char *, ftnlen), e_wsle(void), i_nint(real *
), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(
void), i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, iv;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern /* Subroutine */ int stop1_(void);
static char lineq[128];
static integer lpath, iinst;
extern doublereal readin_(char *, integer *, integer *, ftnlen);
extern /* Subroutine */ int getbuf_(char *, ftnlen), errmsg_(char *,
integer *, integer *, char *, ftnlen, ftnlen), printl_(char *,
ftnlen);
static logical newway;
static integer iccount;
/* Fortran I/O blocks */
static cilist io___665 = { 0, 6, 0, 0, 0 };
static cilist io___666 = { 0, 6, 0, "(1x,a46,i3)", 0 };
static cilist io___667 = { 0, 6, 0, "(a)", 0 };
static cilist io___670 = { 0, 6, 0, "(a)", 0 };
static cilist io___671 = { 0, 6, 0, "(a)", 0 };
static cilist io___672 = { 0, 6, 0, 0, 0 };
/* Get the first line */
iccount = 0;
c1omget_1.nline = 1;
L9:
getbuf_(lineq, (ftnlen)128);
if (*(unsigned char *)lineq == '%') {
++c1omget_1.nline;
goto L9;
}
if (s_cmp(lineq, "---", (ftnlen)3, (ftnlen)3) == 0) {
/* Have TeX input until next line that starts with '---' */
L3:
++c1omget_1.nline;
getbuf_(lineq, (ftnlen)128);
if (inbuff_1.ilbuf > inbuff_1.nlbuf) {
goto L1;
}
goto L2;
L1:
s_wsle(&io___665);
do_lio(&c__9, &c__1, "You did not terminate type 0 TeX input with \""
"---\"", (ftnlen)49);
e_wsle();
stop1_();
L2:
if (s_cmp(lineq, "---", (ftnlen)3, (ftnlen)3) != 0) {
goto L3;
}
/* Force a new line read on first call to readin */
iccount = 128;
}
/* Here, lineq and nline are first non-TeX lines. */
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*nv = i_nint(&r__1);
if (*nv > 24) {
s_wsfe(&io___666);
do_fio(&c__1, "In setup data, number of voices cannot exceed", (
ftnlen)45);
do_fio(&c__1, (char *)&c__24, (ftnlen)sizeof(integer));
e_wsfe();
stop1_();
}
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*noinst = i_nint(&r__1);
if (*noinst > *nv) {
s_wsfe(&io___667);
do_fio(&c__1, "In setup data, cannot have more instruments than stav"
"es", (ftnlen)55);
e_wsfe();
stop1_();
}
newway = *noinst <= 0;
if (newway) {
*noinst = -(*noinst);
}
i__1 = *noinst;
for (iinst = 1; iinst <= i__1; ++iinst) {
/* Seve # of staves per inst in case later drop some inst's. */
if (newway) {
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
c1omget_1.nsperi[iinst - 1] = i_nint(&r__1);
} else if (iinst > 1) {
c1omget_1.nsperi[iinst - 1] = 1;
} else {
c1omget_1.nsperi[iinst - 1] = *nv - *noinst + 1;
}
/* L10: */
}
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*mtrnuml = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*mtrdenl = i_nint(&r__1);
/* c */
/* c Kluge!!! */
/* c */
/* if (mtrdenl .eq. 1) then */
/* mtrdenl = 2 */
/* mtrnuml = mtrnuml*2 */
/* end if */
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*mtrnmp = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*mtrdnp = i_nint(&r__1);
if (*mtrnmp == 0 && *mtrdnp >= 8) {
s_wsfe(&io___670);
do_fio(&c__1, "In setup data, with mtrnmp=0, mtrdnp must be <8", (
ftnlen)47);
e_wsfe();
stop1_();
}
*xmtrnum0 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*newkey = i_nint(&r__1);
/* 130316 */
/* do 11 iinst = 1 , noinst */
commidisig_1.midisig = *newkey;
/* 11 continue */
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*npages = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*nsyst = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)128);
*musize = i_nint(&r__1);
c1omget_1.fracindent = readin_(lineq, &iccount, &c1omget_1.nline, (ftnlen)
128);
if (c1omget_1.fracindent >= 1.f) {
s_wsfe(&io___671);
do_fio(&c__1, "In setup data, fracindent must be <1", (ftnlen)36);
e_wsfe();
stop1_();
}
if (*npages > *nsyst) {
s_wsle(&io___672);
do_lio(&c__9, &c__1, "Error in input file: npages > nsyst", (ftnlen)
35);
e_wsle();
stop1_();
} else if ((*musize - 16) * (*musize - 20) * (*musize - 24) * (*musize -
29) != 0) {
printl_("Musicsize must be 16, 20, 24, or 29", (ftnlen)35);
stop1_();
}
/* Next noinst non-comment lines are names of instruments. */
i__1 = abs(*noinst);
for (i__ = 1; i__ <= i__1; ++i__) {
L5:
getbuf_(lineq, (ftnlen)128);
++c1omget_1.nline;
if (*(unsigned char *)lineq == '%') {
goto L5;
}
/* L4: */
}
/* Mext non-comment line has nv clef names */
L6:
getbuf_(lineq, (ftnlen)128);
++c1omget_1.nline;
if (*(unsigned char *)lineq == '%') {
goto L6;
}
i__1 = *nv;
for (iv = 1; iv <= i__1; ++iv) {
/* if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then */
if (i_indx("brnamstf01234567", lineq + (iv - 1), (ftnlen)16, (ftnlen)
1) == 0) {
errmsg_(lineq, &iv, &c__0, "There should be a clef symbol here!",
(ftnlen)128, (ftnlen)35);
stop1_();
}
/* L7: */
}
i__1 = *nv;
if (s_cmp(lineq + i__1, " ", *nv + 1 - i__1, (ftnlen)1) != 0) {
i__1 = *nv + 1;
errmsg_(lineq, &i__1, &c__0, "There should be a blank here!", (ftnlen)
128, (ftnlen)29);
stop1_();
}
/* Set flag if voice 1 is treble, since it affects vertical spacing */
*bottreb = *(unsigned char *)lineq == 't';
/* Mext non-comment line has path name */
L8:
getbuf_(lineq, (ftnlen)128);
++c1omget_1.nline;
if (*(unsigned char *)lineq == '%') {
goto L8;
}
lpath = i_indx(lineq, " ", (ftnlen)128, (ftnlen)1) - 1;
/* Writing concatenation */
i__2[0] = 2, a__1[0] = "/:";
chax_(ch__2, (ftnlen)1, &c__92);
i__2[1] = 1, a__1[1] = ch__2;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)3);
if (i_indx(ch__1, lineq + (lpath - 1), (ftnlen)3, (ftnlen)1) == 0) {
/* Writing concatenation */
i__3[0] = 47, a__2[0] = "Last character of pathname is not \"/\",\""
":\", or \"";
chax_(ch__2, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__2;
i__3[2] = 2, a__2[2] = "\"!";
s_cat(ch__3, a__2, i__3, &c__3, (ftnlen)50);
errmsg_(lineq, &lpath, &c__0, ch__3, (ftnlen)128, (ftnlen)50);
stop1_();
}
return 0;
} /* g1etset_ */
/* Subroutine */ int g1etx_(char *lineq, integer *iccount, logical *notxtup,
logical *shifton, integer *ibar, real *udsp, real *wheadpt, ftnlen
lineq_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real fnum;
static char dumq[1];
extern /* Subroutine */ int stop1_(void);
static char charq[1];
static integer ipbsc, npbsc;
static logical number;
extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *,
ftnlen, ftnlen), readnum_(char *, integer *, char *, real *,
ftnlen, ftnlen), g1etchar_(char *, integer *, char *, ftnlen,
ftnlen);
/* Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. */
/* In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. */
number = FALSE_;
npbsc = 0;
L1:
g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("PBS:", charq, (ftnlen)4, (ftnlen)1) > 0) {
/* Continue checking here even if "P". */
ipbsc = i_indx("PBS:", charq, (ftnlen)4, (ftnlen)1);
if (bit_test(npbsc,ipbsc)) {
errmsg_(lineq, iccount, ibar, "Only one allowed per symbol!", (
ftnlen)128, (ftnlen)28);
stop1_();
/* else if (.not.notxtup .and. ipbsc.gt.2) then */
/* call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') */
/* call stop1() */
}
npbsc = bit_set(npbsc,ipbsc);
goto L1;
} else if (i_indx("+-.0123456789", charq, (ftnlen)13, (ftnlen)1) > 0) {
number = TRUE_;
if (i_indx("+-", charq, (ftnlen)2, (ftnlen)1) > 0) {
g1etchar_(lineq, iccount, dumq, (ftnlen)128, (ftnlen)1);
if (i_indx(".0123456789", dumq, (ftnlen)11, (ftnlen)1) == 0) {
errmsg_(lineq, iccount, ibar, "Expected a number here!", (
ftnlen)128, (ftnlen)23);
stop1_();
}
}
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == '-') {
fnum = -fnum;
}
if (*(unsigned char *)dumq != 'p') {
--(*iccount);
fnum *= *wheadpt;
}
goto L1;
} else if (*(unsigned char *)charq != ' ') {
errmsg_(lineq, iccount, ibar, "Not allowed in \"X\" symbol!", (ftnlen)
128, (ftnlen)26);
stop1_();
}
/* Done with parsing. Other checks */
if ((6 & npbsc) == 6 || (24 & npbsc) == 24) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Cannot have both \"P\" and \"B\" or \""
"S\" and \":\"!", (ftnlen)128, (ftnlen)44);
stop1_();
}
if (bit_test(npbsc,4)) {
if (number) {
if (*shifton) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Started a group shift without s"
"topping prior one!", (ftnlen)128, (ftnlen)49);
stop1_();
} else {
*shifton = TRUE_;
}
} else {
if (! (*shifton)) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Ended a group shift without sta"
"rting one!", (ftnlen)128, (ftnlen)41);
stop1_();
} else {
*shifton = FALSE_;
}
}
}
/* P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) */
if ((npbsc & 26) == 0) {
*udsp += fnum;
}
if (! number && ! bit_test(npbsc,4)) {
i__1 = *iccount - 1;
errmsg_(lineq, &i__1, ibar, "Must have either a number or a colon "
"in \"X\" symbol!", (ftnlen)128, (ftnlen)51);
stop1_();
}
return 0;
} /* g1etx_ */
/* integer*4 function mytime() */
/* CHARACTER(10) tq */
/* CALL DATE_AND_TIME(TIME=tq) */
/* read(tq,'(2i2,f6.3)')ih,im,ts */
/* mytime = 1000*(ts+60*(im+60*ih)) */
/* return */
/* end */
/* Subroutine */ int getbuf_(char *lineq, ftnlen lineq_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
i__1 = inbuff_1.ipbuf;
s_copy(lineq, inbuff_1.bufq + i__1, lineq_len, inbuff_1.ipbuf +
inbuff_1.lbuf[inbuff_1.ilbuf - 1] - i__1);
inbuff_1.ipbuf += inbuff_1.lbuf[inbuff_1.ilbuf - 1];
++inbuff_1.ilbuf;
return 0;
} /* getbuf_ */
/* Subroutine */ int getchar_(char *lineq, integer *iccount, char *charq,
ftnlen lineq_len, ftnlen charq_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ndxm;
extern /* Subroutine */ int mrec1_(char *, integer *, integer *, ftnlen),
read10_(char *, logical *, ftnlen);
/* Gets the next character out of lineq*128. If pointer iccount=128 on entry, */
/* then reads in a new line. Resets iccount. Ends program if no more input. */
if (*iccount == 128) {
read10_(lineq, &comget_1.lastchar, (ftnlen)128);
if (comget_1.lastchar) {
return 0;
}
if (! commac_1.endmac) {
*iccount = 0;
} else {
commac_1.endmac = FALSE_;
*iccount = commac_1.icchold;
s_copy(lineq, commac_1.lnholdq, (ftnlen)128, (ftnlen)128);
}
if (commac_1.mrecord) {
mrec1_(lineq, iccount, &ndxm, (ftnlen)128);
}
}
++(*iccount);
*(unsigned char *)charq = *(unsigned char *)&lineq[*iccount - 1];
return 0;
/* L999: */
comget_1.lastchar = TRUE_;
return 0;
} /* getchar_ */
/* Subroutine */ int getdyn_(integer *ivx, integer *ip, integer *irest,
integer *iornq, char *lineq, integer *iccount, ftnlen lineq_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2[3], i__3;
real r__1;
char ch__1[4], ch__2[1];
icilist ici__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
, i_nint(real *);
/* Local variables */
static integer ipm, iend;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer idno, idyn;
static real fnum;
static char durq[1];
static integer idno1;
extern /* Subroutine */ int stop1_(void), printl_(char *, ftnlen),
readnum_(char *, integer *, char *, real *, ftnlen, ftnlen),
setbits_(integer *, integer *, integer *, integer *);
static char dynsymq[4];
/* Get info for dynamic mark. Enter after getting "D", iccount sits on "D" */
/* Bits in idyndat are as follows */
/* 00-03 ivx */
/* 04-11 ip */
/* 12-15 code for type of mark */
/* 0 => arbitrary text */
/* 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff */
/* If (.not. fontslur) */
/* 13 => hairpin start, 14,15 => <,> (ending) */
/* else */
/* 13 < start, 14 > start, 15 ending */
/* end if */
/* 16 flag for vertical offset */
/* 17-23 vertical offset + 64 , \internote */
/* 31 Hairpin start (0), stop (1) */
/* idynda2 */
/* 00 flag for horizontal offset */
/* 01-09 (horizontal offset)/10 + 25.6 notehead widths */
/* 10 5th bit for ivx (5/15/10) */
*irest = bit_set(*irest,26);
++comdyn_1.ndyn;
idyn = *ivx;
comdyn_1.idynda2[comdyn_1.ndyn - 1] = 0;
if (*ivx >= 16) {
setbits_(&comdyn_1.idynda2[comdyn_1.ndyn - 1], &c__1, &c__10, &c__1);
}
setbits_(&idyn, &c__8, &c__4, ip);
i__1 = *iccount;
if (s_cmp(lineq + i__1, "\"", *iccount + 1 - i__1, (ftnlen)1) == 0) {
/* text-dynamic */
++comdyn_1.ntxtdyn;
i__1 = *iccount + 1;
iend = *iccount + i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1) +
2;
i__1 = *iccount + 1;
s_copy(comdyn_1.txtdynq + (comdyn_1.ntxtdyn - 1 << 7), lineq + i__1, (
ftnlen)128, iend - 2 - i__1);
/* c Store ivx, ip in bits 0-11 */
/* Store ivx, ip in bits 0-12 */
/* ivxiptxt(ntxtdyn) = idyn */
comdyn_1.ivxiptxt[comdyn_1.ntxtdyn - 1] = *ivx + (*ip << 5);
ipm = i_indx("- +", lineq + (iend - 1), (ftnlen)3, (ftnlen)1);
idno = 0;
} else {
/* Word-group or hairpin */
for (iend = *iccount + 2; iend <= 128; ++iend) {
ipm = i_indx("- +", lineq + (iend - 1), (ftnlen)3, (ftnlen)1);
/* Exit the loop at first blank, "+", or "-" */
if (ipm > 0) {
goto L2;
}
/* L1: */
}
L2:
i__1 = *iccount;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = iend - 1 - i__1;
ici__1.iciunit = lineq + i__1;
/* Writing concatenation */
i__2[0] = 2, a__1[0] = "(a";
i__3 = iend + 47 - *iccount;
chax_(ch__2, (ftnlen)1, &i__3);
i__2[1] = 1, a__1[1] = ch__2;
i__2[2] = 1, a__1[2] = ")";
ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1);
s_rsfi(&ici__1);
do_fio(&c__1, dynsymq, (ftnlen)4);
e_rsfi();
idno = (i_indx("ppppppp pp p mp mf f fp sfz ff fff ffff "
"< > ", dynsymq, (ftnlen)60, (ftnlen)4) + 3) / 4;
/* Save for later down */
idno1 = idno;
}
/* Set flag to check level later if in beam */
*iornq = bit_set(*iornq,23);
if (idno >= 14) {
/* Hairpin here. Check if opposite type from one that's already on */
if (idno == 14 && bit_test(comdyn_1.listdecresc,*ivx) || idno == 15 &&
bit_test(comdyn_1.listcresc,*ivx)) {
printl_(" ", (ftnlen)1);
printl_("Started one kind of hairpin while other is on", (ftnlen)
45);
stop1_();
}
/* Start or stop? */
if (bit_test(comdyn_1.listcresc,*ivx) || bit_test(
comdyn_1.listdecresc,*ivx)) {
/* Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. */
if (! comslur_1.fontslur) {
idno = 15;
}
} else if (comslur_1.fontslur) {
/* Start of font slur */
idno = 13;
} else {
/* Start of postscript slur */
--idno;
}
}
/* Now that we used list[de]cresc, update */
if (idno >= 13) {
if (idno == 15 || comslur_1.fontslur && idno == 14) {
/* Something's ending */
if (bit_test(comdyn_1.listcresc,*ivx)) {
/* It's a cresc! */
comdyn_1.listcresc = bit_clear(comdyn_1.listcresc,*ivx);
} else {
comdyn_1.listdecresc = bit_clear(comdyn_1.listdecresc,*ivx);
}
} else {
/* Something's starting */
if (idno1 == 14) {
/* It's a cresc! */
comdyn_1.listcresc = bit_set(comdyn_1.listcresc,*ivx);
} else {
comdyn_1.listdecresc = bit_set(comdyn_1.listdecresc,*ivx);
}
}
}
setbits_(&idyn, &c__4, &c__12, &idno);
*iccount = iend;
if (ipm != 2) {
/* There is a vertical shift */
idyn = bit_set(idyn,16);
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
idno = i_nint(&fnum);
i__1 = (ipm - 2) * idno + 64;
setbits_(&idyn, &c__7, &c__17, &i__1);
ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1);
if (ipm != 2) {
/* There is a horizontal shift */
/* idynda2(ndyn) = ibset(idyn,23) */
comdyn_1.idynda2[comdyn_1.ndyn - 1] = bit_set(comdyn_1.idynda2[
comdyn_1.ndyn - 1],0);
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
r__1 = fnum * 10;
idno = i_nint(&r__1);
i__1 = (ipm - 2) * idno + 256;
setbits_(&comdyn_1.idynda2[comdyn_1.ndyn - 1], &c__9, &c__1, &
i__1);
}
/* iccount should be on the blank at the end of the entire symbol */
}
comdyn_1.idyndat[comdyn_1.ndyn - 1] = idyn;
return 0;
} /* getdyn_ */
/* Subroutine */ int getfig_(integer *itoff, char *charq, char *lineq,
integer *iccount, logical *isfig, integer *itfig, integer *itsofar,
integer *nodur, char *figq, integer *ivupfig, integer *nfigs, ftnlen
charq_len, ftnlen lineq_len, ftnlen figq_len)
{
/* System generated locals */
address a__1[2];
integer i__1[2];
icilist ici__1;
/* Builtin functions */
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
;
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer i_nint(real *);
/* Local variables */
static integer lfig, loff, noff;
static real fnum;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen);
extern integer ifnodur_(integer *, char *, ftnlen);
/* As of 11/26/08, trapped extra figures in getnote, so no need here. */
/* if (ivx .gt. 2) then */
/* c */
/* c Read past the figure */
/* c */
/* 6 call getchar(lineq,iccount,charq) */
/* if (charq .ne. ' ') go to 6 */
/* return */
/* end if */
++(*nfigs);
*ivupfig = 0;
*itoff = 0;
if (*(unsigned char *)charq == 'x') {
/* Floating figure. */
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = charq;
ici__1.icifmt = "(i1)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&noff, (ftnlen)sizeof(integer));
e_rsfi();
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = charq;
ici__1.icifmt = "(i1)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&loff, (ftnlen)sizeof(integer));
e_rsfi();
*itoff = noff * ifnodur_(&loff, "x", (ftnlen)1);
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
} else {
/* Figure on a note */
*isfig = TRUE_;
}
*itfig = *itsofar + *itoff - *nodur;
lfig = 1;
s_copy(figq, charq, (ftnlen)10, (ftnlen)1);
L5:
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
/* if (charq .ne. ' ') then */
if (i_indx(" +", charq, (ftnlen)2, (ftnlen)1) == 0) {
/* Writing concatenation */
i__1[0] = lfig, a__1[0] = figq;
i__1[1] = 1, a__1[1] = charq;
s_cat(figq, a__1, i__1, &c__2, (ftnlen)10);
++lfig;
goto L5;
} else if (*(unsigned char *)charq == '+') {
/* Get vertical offset for figure. Next character after number has to be blank. */
++(*iccount);
readnum_(lineq, iccount, charq, &fnum, (ftnlen)128, (ftnlen)1);
*ivupfig = i_nint(&fnum);
}
return 0;
} /* getfig_ */
/* Subroutine */ int getgrace_(integer *ivx, integer *nnl, char *lineq,
integer *iccount, integer *islur, integer *iornq, integer *ipl,
integer *ndlev, integer *lastlev, integer *iv, integer *nv, ftnlen
lineq_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *);
/* Local variables */
static integer iclastlev, kv, ing, ioct;
static real fnum;
static char durq[1], charq[1];
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen);
extern integer ifnolev_(char *, integer *, integer *, ftnlen);
/* Grace, comes *before* main note: */
/* UNLESS there's an 'A' or 'W' after the 'G' */
/* ngrace = # of grace note groups so far in block */
/* ivg(ngrace), ipg(ngrace) */
/* nng(ngrace) = # of notes in this group: default = 1 */
/* ngstrt(ngrace) = starting position in nolevg of levels for this grace */
/* multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' */
/* upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' */
/* slurg(ngrace) = logical for slur; default F, input 's' */
/* slashg(ngrace) = T if slash; default is F, input 'x' */
/* These data MUST precede note name of first note */
/* nolevg, naccg: lists of levels and accid's, indexed as described above. */
/* Parameter adjustments */
ndlev -= 25;
ipl -= 25;
--iornq;
islur -= 25;
--nnl;
/* Function Body */
++comgrace_1.ngrace;
comgrace_1.ivg[comgrace_1.ngrace - 1] = *ivx;
comgrace_1.ipg[comgrace_1.ngrace - 1] = nnl[*ivx] + 1;
if (comgrace_1.ngrace == 1) {
comgrace_1.ngstrt[comgrace_1.ngrace - 1] = 1;
} else {
comgrace_1.ngstrt[comgrace_1.ngrace - 1] = comgrace_1.ngstrt[
comgrace_1.ngrace - 2] + comgrace_1.nng[comgrace_1.ngrace - 2]
;
}
islur[*ivx + (nnl[*ivx] + 1) * 24] = bit_set(islur[*ivx + (nnl[*ivx] + 1)
* 24],4);
comgrace_1.nng[comgrace_1.ngrace - 1] = 1;
comgrace_1.multg[comgrace_1.ngrace - 1] = 1;
comgrace_1.upg[comgrace_1.ngrace - 1] = TRUE_;
comgrace_1.slurg[comgrace_1.ngrace - 1] = FALSE_;
comgrace_1.slashg[comgrace_1.ngrace - 1] = FALSE_;
L18:
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("WA", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Grace is on note that was already done, so shift flags forward one note. */
/* This puts flag on actual note with grace; later for W will go ahead one more. */
comgrace_1.ipg[comgrace_1.ngrace - 1] = nnl[*ivx];
islur[*ivx + (nnl[*ivx] + 1) * 24] = bit_clear(islur[*ivx + (nnl[*ivx]
+ 1) * 24],4);
islur[*ivx + nnl[*ivx] * 24] = bit_set(islur[*ivx + nnl[*ivx] * 24],4)
;
if (comgrace_1.slurg[comgrace_1.ngrace - 1]) {
iornq[*ivx + nnl[*ivx] * 24] = bit_set(iornq[*ivx + nnl[*ivx] *
24],24);
}
if (*(unsigned char *)charq == 'A') {
/* close After, clear way-after bit, to ensure priority of most recent A/W */
ipl[*ivx + nnl[*ivx] * 24] = bit_set(bit_clear(ipl[*ivx + nnl[*
ivx] * 24],31),29);
} else {
/* Way after; later assign to following note, and position like normal grace. */
ipl[*ivx + nnl[*ivx] * 24] = bit_set(bit_clear(ipl[*ivx + nnl[*
ivx] * 24],29),31);
}
} else if (*(unsigned char *)charq == 'm') {
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
comgrace_1.multg[comgrace_1.ngrace - 1] = *(unsigned char *)charq -
48;
} else if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) {
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
comgrace_1.nng[comgrace_1.ngrace - 1] = i_nint(&fnum);
} else if (*(unsigned char *)charq == 'l') {
comgrace_1.upg[comgrace_1.ngrace - 1] = FALSE_;
} else if (*(unsigned char *)charq == 's') {
comgrace_1.slurg[comgrace_1.ngrace - 1] = TRUE_;
if (nnl[*ivx] > 0) {
/* If A- or W-grace, set signal to start slur on main note. */
if (bit_test(ipl[*ivx + nnl[*ivx] * 24],31) || bit_test(ipl[*ivx
+ nnl[*ivx] * 24],29)) {
iornq[*ivx + nnl[*ivx] * 24] = bit_set(iornq[*ivx + nnl[*ivx]
* 24],24);
}
}
} else if (*(unsigned char *)charq == 'x') {
comgrace_1.slashg[comgrace_1.ngrace - 1] = TRUE_;
} else if (*(unsigned char *)charq == 'u') {
} else if (*(unsigned char *)charq == 'X') {
/* Space before main note of grace. Number will come next. */
++(*iccount);
readnum_(lineq, iccount, durq, &comgrace_1.graspace[comgrace_1.ngrace
- 1], (ftnlen)128, (ftnlen)1);
--(*iccount);
}
if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) {
goto L18;
}
/* At this point, charq is first note name in grace */
i__1 = comgrace_1.ngstrt[comgrace_1.ngrace - 1] + comgrace_1.nng[
comgrace_1.ngrace - 1] - 1;
for (ing = comgrace_1.ngstrt[comgrace_1.ngrace - 1]; ing <= i__1; ++ing) {
comgrace_1.naccg[ing - 1] = 0;
ioct = 0;
if (ing > comgrace_1.ngstrt[comgrace_1.ngrace - 1]) {
L55:
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == ' ') {
goto L55;
}
}
iclastlev = 0;
L9:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
if (*(unsigned char *)durq == '+') {
*lastlev += 7;
iclastlev += 7;
} else if (*(unsigned char *)durq == '-') {
*lastlev += -7;
iclastlev += -7;
} else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) {
if (comgrace_1.naccg[ing - 1] == 0) {
comgrace_1.naccg[ing - 1] = i_indx("fsn", durq, (ftnlen)3,
(ftnlen)1);
} else {
/* Double accidental */
comgrace_1.naccg[ing - 1] = bit_set(comgrace_1.naccg[ing
- 1],2);
}
} else {
ioct = *(unsigned char *)durq - 48;
}
goto L9;
}
if (ioct > 0) {
*lastlev = ifnolev_(charq, &ioct, &cominsttrans_1.itransamt[
cominsttrans_1.instno[*iv - 1] - 1], (ftnlen)1);
} else {
if (nnl[*ivx] == 0 && ing == comgrace_1.ngstrt[comgrace_1.ngrace
- 1]) {
if (*ivx <= *nv) {
kv = 1;
} else {
kv = 2;
}
*lastlev = ndlev[*iv + kv * 24] + iclastlev;
}
*lastlev = *lastlev - 3 + (ifnolev_(charq, &c__10, &
cominsttrans_1.itransamt[cominsttrans_1.instno[*iv - 1] -
1], (ftnlen)1) - *lastlev + 3) % 7;
}
comgrace_1.nolevg[ing - 1] = *lastlev;
/* L19: */
}
/* Grace could come before first note of block, so reset end level. */
if (nnl[*ivx] == 0) {
if (*ivx <= *nv) {
kv = 1;
} else {
kv = 2;
}
ndlev[*iv + kv * 24] = *lastlev;
}
return 0;
} /* getgrace_ */
/* Subroutine */ int getitransinfo_(logical *from1, integer *ibarcnt, char *
lineq, integer *iccount, integer *ibaroff, integer *nbars, integer *
noinst, integer *iv, ftnlen lineq_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *);
/* Local variables */
static integer ikey;
static real fnum;
static char durq[1];
extern /* Subroutine */ int stop1_(void);
static integer instn;
static logical store;
extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *,
ftnlen, ftnlen);
static integer itramt;
extern /* Subroutine */ int readnum_(char *, integer *, char *, real *,
ftnlen, ftnlen), g1etchar_(char *, integer *, char *, ftnlen,
ftnlen);
/* ccccccccccccccccccccccc */
/* c */
/* c GetiTransInfo.for */
/* c */
/* ccccccccccccccccccccccc */
/* Called from both g1etnote and getnote, after first 'i' in Ki[...] */
/* On entry, iccount points to last char retrieved, which is 'i' */
/* From1: locgical, true if called from g1etnote */
/* ibarcnt: tells whether to set EarlyTransOn to true. */
/* EarlyTransOn set false in blkdata, true here, back to false in topfile. */
/* 110522/110529 */
/* Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] */
/* and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 */
/* so can pass to topfile (via comInstTrans), which is called before getnote. */
/* Otherwise, will store info from getnote. Initialize EarlyTransOn and */
/* LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; */
/* LaterInstTrans from getnote. Zero both out after use. nInstTrans really */
/* only needed for instrument-signatures, not transpositions. iTransAmt is */
/* ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for */
/* each staff. */
/* iTransAmt stored as fn of instrument #, not like iTransKey which is */
/* fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This */
/* simplifies use of iTransAmt for all calls to ifnolev. */
*(unsigned char *)durq = 'x';
/* Can't initialize in declaration stmt, only works onc */
if (! cominsttrans_1.earlytranson) {
cominsttrans_1.earlytranson = *from1 && *ibarcnt == 0;
}
store = cominsttrans_1.earlytranson && *ibarcnt == 0 || *ibarcnt > 0 && !
(*from1);
cominsttrans_1.laterinsttrans = ! (*from1) && *ibarcnt > 0;
if (store) {
cominsttrans_1.ninsttrans = 0;
}
L1:
if (*(unsigned char *)durq == ' ') {
return 0;
}
g1etchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "There must be an instrument number h"
"ere!", (ftnlen)128, (ftnlen)40);
stop1_();
}
if (store) {
++cominsttrans_1.ninsttrans;
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
instn = i_nint(&fnum);
if (instn > *noinst) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Instrument number out of range!", (
ftnlen)128, (ftnlen)31);
stop1_();
}
if (store) {
cominsttrans_1.iinsttrans[cominsttrans_1.ninsttrans - 1] = instn;
}
/* durq is +/- following inst # (for iTransAmt), iccount is on it. */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "1st character after instrument numbe"
"r must be \"+,-\"!", (ftnlen)128, (ftnlen)52);
stop1_();
}
itramt = 44 - *(unsigned char *)durq;
/* +1/-1 for itramt */
g1etchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "There must be a transposition amount"
" here!", (ftnlen)128, (ftnlen)42);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (store) {
cominsttrans_1.itransamt[instn - 1] = i_nint(&fnum) * itramt;
}
/* durq is +/- following iTransAmt (for iTransKey), iccount is on it. */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "1st character after transposition am"
"ount must be \"+,-\"!", (ftnlen)128, (ftnlen)55);
stop1_();
}
ikey = 44 - *(unsigned char *)durq;
/* +1/-1 */
g1etchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "There must be a key indicator here!",
(ftnlen)128, (ftnlen)35);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (store) {
cominsttrans_1.itranskey[cominsttrans_1.ninsttrans - 1] = i_nint(&
fnum) * ikey;
}
/* durq is now 1st character after iTransKey, should be either 'i' or ' ' */
if (*(unsigned char *)durq != 'i' && *(unsigned char *)durq != ' ') {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "There must be blank or \"i\" here!", (
ftnlen)128, (ftnlen)32);
stop1_();
}
goto L1;
} /* getitransinfo_ */
/* Subroutine */ int getmidi_(integer *noinstarg, char *lineq, integer *
iccount, integer *ibarcnt, integer *ibaroff, integer *nbars, integer *
lenbar, integer *mtrdenl, logical *first, ftnlen lineq_len)
{
/* Initialized data */
static shortint midinum[26] = { 1,5,7,13,20,25,33,41,42,43,44,57,58,59,61,
65,66,67,68,69,71,72,74,75,8,55 };
/* System generated locals */
address a__1[2];
integer i__1, i__2[2], i__3, i__4;
real r__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real pausemid;
extern /* Subroutine */ int midievent_(char *, integer *, integer *,
ftnlen);
static integer icm, ipm;
static real qpm;
static integer ivx;
static real fnum;
static char durq[1];
extern /* Subroutine */ int stop1_(void);
static integer iname, numb16;
static char instq[2];
extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *,
ftnlen, ftnlen), addmidi_(integer *, integer *, integer *,
integer *, real *, logical *, logical *), getchar_(char *,
integer *, char *, ftnlen, ftnlen), readnum_(char *, integer *,
char *, real *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___719 = { 0, 6, 0, "(a)", 0 };
static cilist io___720 = { 0, 15, 0, "(a)", 0 };
/* subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, */
/* Use this from both pmxa and pmxb to input and check midi data. "first" tells */
/* whether pmxa or pmxb. If .not.first, then tempo and pause commands cause */
/* things to be written immediately into the midi storage buffers. */
/* immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing */
/* nmidsec section starts and stops based on PLAYING macros (not recording). */
/* Instrument codes */
/* XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX */
/* bsXobXbaXclXflXreXctXvo */
L1:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 't') {
/* Tempo in beats ber minute */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Expected an integer here for the"
" pause!", (ftnlen)128, (ftnlen)39);
stop1_();
/* else if (mmacrec) then */
/* call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, */
/* * 'Cannot change MIDI tempo while recording a MidiMacro!') */
/* call stop1() */
}
readnum_(lineq, iccount, durq, &qpm, (ftnlen)128, (ftnlen)1);
--(*iccount);
if (! (*first)) {
i__1 = i_nint(&qpm);
midievent_("t", &i__1, &c__0, (ftnlen)1);
commmac_1.gottempo = TRUE_;
}
goto L1;
} else if (*(unsigned char *)durq == 'p') {
/* Insert a pause. pausemid = pause in 1/4's */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Expected a number here for the p"
"ause!", (ftnlen)128, (ftnlen)37);
stop1_();
}
readnum_(lineq, iccount, durq, &pausemid, (ftnlen)128, (ftnlen)1);
--(*iccount);
if (! (*first)) {
/* Compute a meter for the pause. This is only to keep MidiNotate on track. */
/* Round pause to nearest 16th. Let denominator always be 16. */
r__1 = pausemid * 4;
numb16 = i_nint(&r__1);
midievent_("m", &numb16, &c__16, (ftnlen)1);
/* Put in pausemid beats of rest */
i__1 = commidi_1.numchan - 1;
for (icm = 0; icm <= i__1; ++icm) {
r__1 = numb16 * 4.f;
addmidi_(&icm, &c__0, &c__0, &c__0, &r__1, &c_true, &c_false);
/* L3: */
}
r__1 = pausemid * 240;
comevent_1.miditime += i_nint(&r__1);
/* Restore meter */
i__1 = *mtrdenl * *lenbar / 64;
midievent_("m", &i__1, mtrdenl, (ftnlen)1);
}
goto L1;
} else if (*(unsigned char *)durq == 'i') {
/* c Instrument numbers or letters. Expect nv of them. */
/* Instrument numbers or letters. Expect noinst of them. */
/* do 2 ivx = 1 , nv */
i__1 = *noinstarg;
for (ivx = 1; ivx <= i__1; ++ivx) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq > 96) {
/* It's a lowercase letter. Get another, find corr. instrument #. */
*(unsigned char *)instq = *(unsigned char *)durq;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* Writing concatenation */
i__2[0] = 1, a__1[0] = instq;
i__2[1] = 1, a__1[1] = durq;
s_cat(instq, a__1, i__2, &c__2, (ftnlen)2);
iname = i_indx("XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuX"
"frXsoXalXteXbsXobXbaXclXflXreXctXvo", instq, (ftnlen)
79, (ftnlen)2) / 3;
if (iname == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Unrecognized 2-letter mi"
"di instrument name!", (ftnlen)128, (ftnlen)43);
stop1_();
}
commidi_1.midinst[ivx - 1] = midinum[iname - 1] - 1;
} else {
/* Expect a number, followed by ":" if that is followed by another number. */
/* I.e., if after call to readnum, durq is not ":", it must be either blank */
/* or next instrument letter. */
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Expected a midi instrume"
"nt number here!", (ftnlen)128, (ftnlen)39);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commidi_1.midinst[ivx - 1] = i_nint(&fnum) - 1;
if (commidi_1.midinst[ivx - 1] < 0 || commidi_1.midinst[ivx -
1] > 255) {
i__3 = *iccount - 1;
i__4 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__3, &i__4, "Midi instrument number mus"
"t be in range 1-128!", (ftnlen)128, (ftnlen)46);
stop1_();
}
if (*(unsigned char *)durq != ':') {
--(*iccount);
}
}
/* L2: */
}
goto L1;
} else if (*(unsigned char *)durq == 'v') {
/* Get volumes for each instrument. Expect nv of them. */
/* Follow same pattern as for insttrument numbers above. */
/* do 7 ivx = 1 , nv */
i__1 = *noinstarg;
for (ivx = 1; ivx <= i__1; ++ivx) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Expected a midi velocity num"
"ber here!", (ftnlen)128, (ftnlen)37);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commvel_1.midivel[ivx - 1] = i_nint(&fnum) - 1;
if (commvel_1.midivel[ivx - 1] < 0 || commvel_1.midivel[ivx - 1]
> 127) {
i__3 = *iccount - 1;
i__4 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__3, &i__4, "Midi velocity must be in range"
" 1-128!", (ftnlen)128, (ftnlen)37);
stop1_();
}
if (*(unsigned char *)durq != ':') {
--(*iccount);
}
/* L7: */
}
goto L1;
} else if (*(unsigned char *)durq == 'b') {
/* Get balance for each instrument. Expect nv of them. */
/* Follow same pattern as for instrument numbers above. */
/* do 8 ivx = 1 , nv */
i__1 = *noinstarg;
for (ivx = 1; ivx <= i__1; ++ivx) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Expected a balance number he"
"re!", (ftnlen)128, (ftnlen)31);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commvel_1.midibal[ivx - 1] = i_nint(&fnum) - 1;
if (commvel_1.midibal[ivx - 1] < 0 || commvel_1.midibal[ivx - 1]
> 127) {
i__3 = *iccount - 1;
i__4 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__3, &i__4, "Midi balance must be in range "
"1-128!", (ftnlen)128, (ftnlen)36);
stop1_();
}
if (*(unsigned char *)durq != ':') {
--(*iccount);
}
/* L8: */
}
goto L1;
} else if (*(unsigned char *)durq == 'T') {
/* Get transposition for each instrument. Expect nv of them. */
/* Follow similar pattern as above, but separator is +|-. */
/* do 9 ivx = 1 , nv */
i__1 = *noinstarg;
for (ivx = 1; ivx <= i__1; ++ivx) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
ipm = i_indx("-+", durq, (ftnlen)2, (ftnlen)1);
if (ipm == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Expected \"+\" or \"-\" for "
"midi transposition here!", (ftnlen)128, (ftnlen)48);
stop1_();
}
ipm = (ipm << 1) - 3;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__3, "Expected a number here!", (
ftnlen)128, (ftnlen)23);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commvel_1.miditran[ivx - 1] = ipm * i_nint(&fnum);
/* if (mod(miditran(ivx),12).ne. 0) then */
/* call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, */
/* * 'Midi transposition limited to multiples of 12!') */
/* call stop1() */
/* end if */
--(*iccount);
/* L9: */
}
goto L1;
} else if (*(unsigned char *)durq == 'g') {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789", durq, (ftnlen)10, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Expected an integer here for the"
" midi gap!", (ftnlen)128, (ftnlen)42);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commidi_1.mgap = i_nint(&fnum);
--(*iccount);
goto L1;
} else if (*(unsigned char *)durq == 'M') {
/* MidiMacros */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'R') {
/* Start recording */
if (commmac_1.mmacrec) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "You tried to record a MidiMa"
"cro while already recording!", (ftnlen)128, (ftnlen)
56);
stop1_();
}
commmac_1.mmacrec = TRUE_;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Expected MidiMacro ID number"
" here!", (ftnlen)128, (ftnlen)34);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
if (! (*first)) {
commmac_1.immac = i_nint(&fnum);
if (commmac_1.immac > 20) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "MidiMacro ID cannot exce"
"ed 20!", (ftnlen)128, (ftnlen)30);
stop1_();
}
/* Save the start time */
commmac_1.mmactime[commmac_1.immac - 1] = comevent_1.miditime;
i__1 = commidi_1.numchan;
for (icm = 0; icm <= i__1; ++icm) {
if (icm < commidi_1.numchan) {
if (commidi_1.restpend[icm]) {
/* Adjust if there's a rest at end of prior section. Insert dummy turnoff. */
/* (This causes two turn-offs in a row, which testmidi sees as an error). */
/* Before: section1 ------rest------- section2(to be recorded) */
/* After: section1 rest1 now rest2 section2(recorded) */
addmidi_(&icm, &c__30, &c__0, &c__0, &
commidi_1.trest[icm], &c_false, &c_true);
commidi_1.trest[icm] = 0.f;
commidi_1.restpend[icm] = FALSE_;
}
} else {
if (comevent_1.miditime > comevent_1.lasttime) {
/* Insert a dummy turnoff in conductor track */
r__1 = (comevent_1.miditime - comevent_1.lasttime)
/ 15.f;
addmidi_(&icm, &c__30, &c__0, &c__0, &r__1, &
c_false, &c_true);
comevent_1.lasttime = comevent_1.miditime;
}
}
commmac_1.mmacstrt[icm + commmac_1.immac * 25 - 25] =
commidi_1.imidi[icm] + 1;
/* L4: */
}
}
goto L1;
} else if (i_indx("123456789P", durq, (ftnlen)10, (ftnlen)1) == 0) {
/* End recording; close the open macro. Get immac from common. */
if (! commmac_1.mmacrec) {
i__1 = *iccount - 1;
i__3 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__1, &i__3, "You tried to end a MidiMacro b"
"efore starting one!", (ftnlen)128, (ftnlen)49);
stop1_();
}
commmac_1.mmacrec = FALSE_;
--(*iccount);
if (! (*first)) {
/* Save the macro duration */
commmac_1.mmactime[commmac_1.immac - 1] = comevent_1.miditime
- commmac_1.mmactime[commmac_1.immac - 1];
i__1 = commidi_1.numchan;
for (icm = 0; icm <= i__1; ++icm) {
if (icm < commidi_1.numchan) {
if (commidi_1.restpend[icm]) {
addmidi_(&icm, &c__30, &c__0, &c__0, &
commidi_1.trest[icm], &c_false, &c_true);
commidi_1.trest[icm] = 0.f;
commidi_1.restpend[icm] = FALSE_;
}
} else {
if (comevent_1.miditime > comevent_1.lasttime) {
/* Insert a dummy turnoff in conductor track if needed. */
r__1 = (comevent_1.miditime - comevent_1.lasttime)
/ 15.f;
addmidi_(&icm, &c__30, &c__0, &c__0, &r__1, &
c_false, &c_true);
comevent_1.lasttime = comevent_1.miditime;
}
}
commmac_1.mmacend[icm + commmac_1.immac * 25 - 25] =
commidi_1.imidi[icm];
/* L5: */
}
}
if (*(unsigned char *)durq != ' ') {
goto L1;
}
} else if (*(unsigned char *)durq == 'P') {
/* Play Back a Macro */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Expected MidiMacro ID number"
" here!", (ftnlen)128, (ftnlen)34);
stop1_();
}
if (commmac_1.mmacrec) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "You tried to play a MidiMacr"
"o before ending recording!", (ftnlen)128, (ftnlen)54);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
if (! (*first)) {
commmac_1.immac = i_nint(&fnum);
if (commmac_1.mmactime[commmac_1.immac - 1] == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Cannot play a MIDI macro"
" before recording it!", (ftnlen)128, (ftnlen)45);
stop1_();
}
i__1 = commidi_1.numchan;
for (icm = 0; icm <= i__1; ++icm) {
if (icm < commidi_1.numchan) {
if (commidi_1.restpend[icm]) {
addmidi_(&icm, &c__30, &c__0, &c__0, &
commidi_1.trest[icm], &c_false, &c_true);
commidi_1.trest[icm] = 0.f;
commidi_1.restpend[icm] = FALSE_;
}
} else {
if (comevent_1.miditime > comevent_1.lasttime) {
/* Insert a dummy turnoff in conductor track */
r__1 = (comevent_1.miditime - comevent_1.lasttime)
/ 15.f;
addmidi_(&icm, &c__30, &c__0, &c__0, &r__1, &
c_false, &c_true);
}
}
commmac_1.msecend[icm + commmac_1.nmidsec * 25 - 25] =
commidi_1.imidi[icm];
commmac_1.msecstrt[icm + (commmac_1.nmidsec + 1) * 25 -
25] = commmac_1.mmacstrt[icm + commmac_1.immac *
25 - 25];
commmac_1.msecend[icm + (commmac_1.nmidsec + 1) * 25 - 25]
= commmac_1.mmacend[icm + commmac_1.immac * 25 -
25];
commmac_1.msecstrt[icm + (commmac_1.nmidsec + 2) * 25 -
25] = commidi_1.imidi[icm] + 1;
/* L6: */
}
commmac_1.nmidsec += 2;
/* Update running time */
comevent_1.miditime += commmac_1.mmactime[commmac_1.immac - 1]
;
comevent_1.lasttime = comevent_1.miditime;
}
goto L1;
} else {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Illegal character in MidiMacro s"
"ub-command!", (ftnlen)128, (ftnlen)43);
stop1_();
}
} else if (*(unsigned char *)durq == 'd') {
commidi_1.debugmidi = TRUE_;
goto L1;
} else if (*(unsigned char *)durq != ' ') {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Illegal character in MIDI input data!"
, (ftnlen)128, (ftnlen)37);
s_wsfe(&io___719);
do_fio(&c__1, "May be too many args to i,v,b, or T. As of Ver. 2.7, "
"should be noinst, not nv", (ftnlen)77);
e_wsfe();
s_wsfe(&io___720);
do_fio(&c__1, "May be too many args to i,v,b, or T. As of Ver. 2.7, "
"should be noinst, not nv", (ftnlen)77);
e_wsfe();
stop1_();
}
if (! commmac_1.gottempo && ! (*first)) {
/* If no tempo is set on first call on the pmxb pass, then set it */
midievent_("t", &c__96, &c__0, (ftnlen)1);
commmac_1.gottempo = TRUE_;
}
return 0;
} /* getmidi_ */
/* Subroutine */ int getnote_(logical *loop)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[5], a__4[6], a__5[8], a__6[13];
integer i__1, i__2, i__3, i__4[2], i__5[3], i__6[5], i__7[6], i__8[8],
i__9[13];
real r__1;
char ch__1[1], ch__2[12], ch__3[10], ch__4[13], ch__5[1], ch__6[69],
ch__7[11], ch__8[3], ch__9[9], ch__10[61], ch__11[8], ch__12[82],
ch__13[83], ch__14[62], ch__15[122], ch__16[15], ch__17[59],
ch__18[70], ch__19[36];
icilist ici__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void);
double r_mod(real *, real *);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), do_lio(
integer *, integer *, char *, ftnlen), e_wsle(void), i_nint(real *
), lbit_shift(integer, integer);
/* Subroutine */ int s_stop(char *, ftnlen);
double log(doublereal);
integer s_rsfi(icilist *), e_rsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer lentemp;
extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen,
ftnlen), getgrace_(integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, ftnlen);
extern integer igetbits_(integer *, integer *, integer *);
static integer idotform;
extern /* Subroutine */ int newvoice_(integer *, char *, logical *,
ftnlen);
static integer j;
extern /* Subroutine */ int readmeter_(char *, integer *, integer *,
integer *, ftnlen), midievent_(char *, integer *, integer *,
ftnlen);
static integer ic, jv, kv, ipm, ivf, ndx;
static real dum;
static integer iiv, iis, isl, iip, npg1, num1, iadj, nadj, lclf;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static logical cdot;
static integer nole, ioct;
static real fnum;
static char dotq[1], durq[1], dumq[1];
extern /* Subroutine */ int getx_(char *, integer *, integer *, logical *,
real *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, char *, integer *, ftnlen, ftnlen);
static integer itup, nnnl, ntup, ndxm, nfig1;
extern /* Subroutine */ int mrec1_(char *, integer *, integer *, ftnlen);
static integer ipg1r;
extern /* Subroutine */ int stop1_(void);
static integer lhead;
static char charq[1], lineq[128];
static logical moved;
static integer ndoub;
static char tempq[24];
extern /* Subroutine */ int sslur_(char *, integer *, integer *, integer *
, integer *, integer *, integer *, integer *, integer *, logical *
, integer *, char *, ftnlen, ftnlen);
static integer ifnum, nvold, iinow, iinst;
extern /* Subroutine */ int getitransinfo_(logical *, integer *, char *,
integer *, integer *, integer *, integer *, integer *, ftnlen);
static logical quoted;
static char hdlndq[59];
extern integer lenstr_(char *, integer *, ftnlen);
static integer numnum;
extern /* Subroutine */ int getorn_(char *, integer *, integer *, integer
*, logical *, integer *, integer *, integer *, logical *, logical
*, integer *, ftnlen);
static integer nnlivx;
extern /* Subroutine */ int littex_(integer *, integer *, integer *,
logical *, char *, integer *, ftnlen), getfig_(integer *, char *,
char *, integer *, logical *, integer *, integer *, integer *,
char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
static integer nactmp;
extern /* Subroutine */ int getdyn_(integer *, integer *, integer *,
integer *, char *, integer *, ftnlen), getbuf_(char *, ftnlen);
extern integer ncmidf_(char *, ftnlen);
static integer nnliiv;
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer ibaroff, lenbeat;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), getmidi_(integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, logical *, ftnlen),
readnum_(char *, integer *, char *, real *, ftnlen, ftnlen);
static integer iofforn;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *), chkpm4ac_(char *, integer *, integer *, logical *,
ftnlen);
static integer numshft;
static real xofforn;
extern integer ifnolev_(char *, integer *, integer *, ftnlen), ifnodur_(
integer *, char *, ftnlen);
static real fmovbrk;
extern integer numclef_(char *, ftnlen);
static integer itother;
extern /* Subroutine */ int spsslur_(char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, logical *, integer *, char *, ftnlen, ftnlen);
static integer lvoltxt, ltopnam, namstrt;
static real tintstf;
/* Fortran I/O blocks */
static cilist io___724 = { 0, 11, 0, "(a)", 0 };
static cilist io___732 = { 0, 6, 0, 0, 0 };
static cilist io___746 = { 0, 6, 0, 0, 0 };
static cilist io___747 = { 0, 6, 0, 0, 0 };
static cilist io___752 = { 0, 6, 0, 0, 0 };
static cilist io___754 = { 0, 6, 0, 0, 0 };
static cilist io___755 = { 0, 6, 0, 0, 0 };
static cilist io___758 = { 0, 6, 0, 0, 0 };
static cilist io___764 = { 0, 11, 0, "(a)", 0 };
static cilist io___765 = { 0, 11, 0, "(a)", 0 };
static cilist io___768 = { 0, 11, 0, "(a)", 0 };
static cilist io___769 = { 0, 11, 0, "(a)", 0 };
static cilist io___770 = { 0, 11, 0, "(a11,i2,a)", 0 };
static cilist io___771 = { 0, 11, 0, "(a9,i2,a)", 0 };
static cilist io___773 = { 0, 11, 0, "(a8,i1,a3)", 0 };
static cilist io___774 = { 0, 11, 0, "(a9,i2,a4)", 0 };
static cilist io___775 = { 0, 11, 0, "(a8,i1,a)", 0 };
static cilist io___776 = { 0, 11, 0, "(a9,i2,a)", 0 };
static cilist io___777 = { 0, 6, 0, 0, 0 };
static cilist io___778 = { 0, 6, 0, 0, 0 };
static cilist io___791 = { 0, 6, 0, 0, 0 };
static cilist io___793 = { 0, 11, 0, "(a)", 0 };
static cilist io___794 = { 0, 11, 0, "(a)", 0 };
static cilist io___795 = { 0, 11, 0, "(a)", 0 };
static cilist io___796 = { 0, 11, 0, "(a)", 0 };
static cilist io___798 = { 0, 11, 0, "(a)", 0 };
static cilist io___801 = { 0, 11, 0, "(a)", 0 };
static cilist io___802 = { 0, 11, 0, "(a)", 0 };
static cilist io___803 = { 0, 11, 0, "(a)", 0 };
static cilist io___804 = { 0, 11, 0, "(a)", 0 };
static cilist io___805 = { 0, 11, 0, "(a)", 0 };
static cilist io___806 = { 0, 11, 0, "(a)", 0 };
static cilist io___807 = { 0, 11, 0, "(a)", 0 };
static cilist io___808 = { 0, 11, 0, "(a)", 0 };
/* nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined */
/* ivx is current ivmx, and is the index for all notes, acc's etc. */
cdot = FALSE_;
L1:
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
if (comget_1.lastchar) {
return 0;
}
if (*(unsigned char *)charq == ' ') {
goto L1;
}
if (*(unsigned char *)charq == '%') {
/* Check for a bar number format: */
if (all_1.iccount == 1 && *(unsigned char *)&lineq[1] == ' ' &&
i_indx("bB1234567890", lineq + 2, (ftnlen)12, (ftnlen)1) > 0)
{
if (comlast_1.islast) {
s_wsfe(&io___724);
do_fio(&c__1, lineq, lenstr_(lineq, &c__128, (ftnlen)128));
e_wsfe();
}
}
all_1.iccount = 128;
goto L1;
}
/* Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' */
if (comget_1.rptprev) {
comget_1.rptnd1 = *(unsigned char *)charq == '/';
comget_1.rptprev = FALSE_;
}
/* Repeat at end of a piece */
if (*(unsigned char *)charq >= 97 && *(unsigned char *)charq <= 103 || *(
unsigned char *)charq == 'r') {
if (cdot) {
goto L28;
}
/* This is a note/rest. */
idotform = 0;
numnum = 0;
/* If start of line of music, set pitch from previous */
if (commvl_1.ivx <= all_1.nv) {
kv = 1;
} else {
kv = 2;
}
if (all_1.nnl[commvl_1.ivx - 1] == 0) {
comnotes_1.lastlev = comnotes_1.ndlev[all_1.iv + kv * 24 - 25];
}
/* notcrd is used to tell if orn. goes on main note or chord note */
/* notcrd = .true. !Move dow. Was not observed if dotted shortcut. */
/* Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. */
L28:
/* Moved this from just above, 2 Feb 02 */
comnotes_1.notcrd = TRUE_;
++all_1.nnl[commvl_1.ivx - 1];
if (comget_1.ornrpt) {
/* Replicate ornament bits, also bit 23 for beam handling if chord. */
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 1]
|= all_1.iornq[commvl_1.ivx - 1];
if ((all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24
- 1] & 32896) > 0) {
/* This is a trill (bit 7 or 15) so must dup the parameters */
++comtrill_1.ntrill;
comtrill_1.ivtrill[comtrill_1.ntrill - 1] = commvl_1.ivx;
comtrill_1.iptrill[comtrill_1.ntrill - 1] = all_1.nnl[
commvl_1.ivx - 1];
comtrill_1.xnsktr[comtrill_1.ntrill - 1] = comtrill_1.xnsktr[
comtrill_1.ntrill - 2];
}
}
if (comget_1.stickys) {
/* Grab stemlength shortening parameters from prior note */
all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],27);
i__1 = igetbits_(&all_1.mult[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25], &c__3, &c__28);
setbits_(&all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25], &c__3, &c__28, &i__1);
}
if (comfb_1.autofbon && comfb_1.tautofb > comtol_1.tol && !
comget_1.fbon) {
/* Doing auto forced beams, and period has been set, so check if this note */
/* starts a period. */
/* if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then */
r__1 = all_1.itsofar[commvl_1.ivx - 1] - comfb_1.t1autofb;
if (r_mod(&r__1, &comfb_1.tautofb) < comtol_1.tol) {
/* Start a forced beam here */
++comfb_1.nfb[commvl_1.ivx - 1];
comget_1.fbon = TRUE_;
*(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx + comfb_1.nfb[
commvl_1.ivx - 1] * 24 - 25] = 'x';
comfb_1.t1fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1] *
24 - 25] = (real) all_1.itsofar[commvl_1.ivx - 1];
}
}
if (comget_1.fbon) {
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 25],30);
}
*(unsigned char *)dotq = 'x';
if (*(unsigned char *)charq == 'r') {
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],0);
}
if (bit_test(all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],0)) {
/* Rest stuff. First check if previous note was full-bar-pause */
i__1 = all_1.iccount;
if (s_cmp(lineq + i__1, " ", all_1.iccount + 1 - i__1, (ftnlen)1)
== 0 && all_1.nnl[commvl_1.ivx - 1] > 1) {
if (bit_test(all_1.islur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25],19)) {
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.islur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],19);
}
}
/* Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 */
/* for voice a or b. Set a-types at 0 as encountered and adjust later */
/* after '//'. (Override heights will be set to 100+offset) */
if (commvl_1.ivx <= all_1.nv) {
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = 0;
} else {
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = 2;
}
}
L2:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
ic = *(unsigned char *)durq;
if (ic <= 57 && ic >= 48) {
/* Digit */
if (numnum == 0) {
comnotes_1.nnodur = ic - 48;
numnum = 1;
goto L2;
} else if (numnum == 1) {
ioct = ic - 48;
numnum = 2;
goto L2;
} else {
s_wsle(&io___732);
do_lio(&c__9, &c__1, ">2 digits in note sym., ivx,nn:", (
ftnlen)31);
do_lio(&c__3, &c__1, (char *)&commvl_1.ivx, (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&all_1.nnl[commvl_1.ivx - 1], (
ftnlen)sizeof(integer));
e_wsle();
stop1_();
}
} else if (*(unsigned char *)durq == 'd') {
*(unsigned char *)dotq = *(unsigned char *)durq;
i__1 = all_1.iccount;
if (s_cmp(lineq + i__1, "d", all_1.iccount + 1 - i__1, (ftnlen)1)
== 0) {
/* Double dot. */
++all_1.iccount;
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],3);
}
i__1 = all_1.iccount;
if (i_indx("+-", lineq + i__1, (ftnlen)2, all_1.iccount + 1 -
i__1) > 0) {
/* move a dot, unless next char is not part of a number */
i__1 = all_1.iccount + 1;
if (i_indx("0123456789.", lineq + i__1, (ftnlen)11,
all_1.iccount + 2 - i__1) == 0) {
goto L2;
}
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],19);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
++comcc_1.ndotmv[commvl_1.ivx - 1];
++all_1.iccount;
readnum_(lineq, &all_1.iccount, dumq, &comcc_1.updot[
commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx - 1] * 24
- 25], (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '-') {
comcc_1.updot[commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx
- 1] * 24 - 25] = -comcc_1.updot[commvl_1.ivx +
comcc_1.ndotmv[commvl_1.ivx - 1] * 24 - 25];
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
/* Vertical shift also */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &comcc_1.rtdot[
commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx - 1] *
24 - 25], (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)dumq == '-') {
comcc_1.rtdot[commvl_1.ivx + comcc_1.ndotmv[
commvl_1.ivx - 1] * 24 - 25] = -comcc_1.rtdot[
commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx -
1] * 24 - 25];
}
} else {
comcc_1.rtdot[commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx
- 1] * 24 - 25] = 0.f;
}
--all_1.iccount;
}
goto L2;
} else if (*(unsigned char *)durq == 'p') {
/* Full-bar rest as pause */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],19);
goto L2;
} else if (*(unsigned char *)durq == 'b') {
/* Blank rest */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],29);
goto L2;
} else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Accidental */
if (all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] == 0) {
/* No accidental has been set yet */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = i_indx("fsn", durq, (ftnlen)3, (ftnlen)1);
} else {
/* Repeated accid, so must be double */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],2);
}
goto L2;
} else if (*(unsigned char *)durq == 'i') {
/* Set flag for MIDI-only accidental. */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],17);
goto L2;
} else if (*(unsigned char *)durq == 'c') {
/* Set flags for cautionary accidental */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],31);
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 1] =
bit_set(all_1.iornq[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 1],31);
goto L2;
} else if (i_indx("+-<>", durq, (ftnlen)4, (ftnlen)1) > 0) {
ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) - 2;
if (! bit_test(all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],0)) {
/* A note, not a rest. */
chkpm4ac_(lineq, &all_1.iccount, &all_1.nacc[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25], &moved, (
ftnlen)128);
if (moved) {
goto L2;
}
/* Octave jump with a note */
if (numnum < 2) {
comnotes_1.lastlev += ipm * 7;
} else {
ioct += ipm;
}
goto L2;
} else {
/* Override default height of a rest */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
i__1 = all_1.iccount - 2;
if (s_cmp(lineq + i__1, ".", all_1.iccount - 1 - i__1, (
ftnlen)1) == 0) {
/* Kluge in case there is a shortcut ".". It will have been sucked up by */
/* readnum. (Same doesn't hold for ",") */
all_1.iccount += -2;
goto L2;
}
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = ipm * i_nint(&fnum) + 100;
/* There may be more characters for this rest */
--all_1.iccount;
goto L2;
}
} else if (*(unsigned char *)durq == 'x') {
/* Xtuplet. Count number of doubled notes (for unequal xtups) */
if (bit_test(all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],18)) {
ndoub = 1;
} else {
ndoub = 0;
}
/* Will set all durations to 0 except last one. Set flag on this note. */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],28);
/* Next input will be digit */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
ntup = i_nint(&fnum);
if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double xtup note to make an un= xtup. Here xtup number already set but may also */
/* have this command before. */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],18);
if (*(unsigned char *)durq == 'F') {
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.nacc[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],19);
}
ndoub = 1;
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
} else if (*(unsigned char *)durq == 'd') {
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],27);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
}
/* Only other possibilities here are ' ' or 'n' */
if (*(unsigned char *)durq == 'n') {
/* Alter xtup number */
i__1 = all_1.iccount;
if (s_cmp(lineq + i__1, " ", all_1.iccount + 1 - i__1, (
ftnlen)1) == 0) {
/* If the only modifier is 'n', cancel the number */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.islur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],31);
} else {
numshft = 0;
L30:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == 'f') {
/* Flip up-down-ness */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],14);
goto L30;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Vertical or horiz shift */
++numshft;
iofforn = 1;
if (*(unsigned char *)durq == '-') {
iofforn = -1;
}
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &xofforn, (
ftnlen)128, (ftnlen)1);
--all_1.iccount;
if (numshft == 1) {
/* Vertical shift */
iofforn = iofforn * i_nint(&xofforn) + 16;
/* Turn on bit 1; set bits 2-6 to iofforn */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] |= (iofforn << 2) + 2;
} else {
/* Horizontal shift */
r__1 = xofforn * 10;
iofforn = iofforn * i_nint(&r__1) + 16;
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],7);
setbits_(&all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25], &c__5, &
c__9, &iofforn);
}
goto L30;
} else if (*(unsigned char *)durq == 's') {
/* Slope adjustment for bracket */
all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.mult[commvl_1.ivx
+ all_1.nnl[commvl_1.ivx - 1] * 24 - 25],4);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
iofforn = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) -
2;
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &xofforn, (
ftnlen)128, (ftnlen)1);
--all_1.iccount;
r__1 = iofforn * xofforn + 16;
iofforn = i_nint(&r__1);
setbits_(&all_1.mult[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25], &c__5, &c__5, &
iofforn);
} else if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1)
> 0) {
/* Replacement printed number */
readnum_(lineq, &all_1.iccount, durq, &xofforn, (
ftnlen)128, (ftnlen)1);
i__1 = i_nint(&xofforn);
setbits_(&all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25], &c__5, &c__22, &
i__1);
--all_1.iccount;
goto L30;
}
}
}
/* Set note level of 1st note of xtup, provided not a rest */
if (! bit_test(all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],0)) {
if (numnum == 2) {
comnotes_1.lastlev = ifnolev_(charq, &ioct, &
cominsttrans_1.itransamt[cominsttrans_1.instno[
all_1.iv - 1] - 1], (ftnlen)1);
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = comnotes_1.lastlev;
} else {
comnotes_1.lastlev = comnotes_1.lastlev - 3 + (ifnolev_(
charq, &c__10, &cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (ftnlen)
1) - comnotes_1.lastlev + 3) % 7;
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = comnotes_1.lastlev;
}
}
for (comnotes_1.npreslur = comnotes_1.npreslur;
comnotes_1.npreslur >= 1; --comnotes_1.npreslur) {
/* Set note level for preslur on starting note of xtuplet */
setbits_(&all_1.isdat2[all_1.nsdat - comnotes_1.npreslur], &
c__7, &c__19, &comnotes_1.lastlev);
/* L40: */
}
numnum = 0;
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= 0;
i__1 = ntup;
for (itup = 2; itup <= i__1; ++itup) {
if (comget_1.ornrpt) {
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 1] |= all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 1] & 10026991;
if ((all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 1] & 32896) > 0) {
/* This is a trill (bit 7 or 15) so must dup the parameters */
++comtrill_1.ntrill;
comtrill_1.ivtrill[comtrill_1.ntrill - 1] =
commvl_1.ivx;
comtrill_1.iptrill[comtrill_1.ntrill - 1] = all_1.nnl[
commvl_1.ivx - 1];
comtrill_1.xnsktr[comtrill_1.ntrill - 1] =
comtrill_1.xnsktr[comtrill_1.ntrill - 2];
}
}
++all_1.nnl[commvl_1.ivx - 1];
if (comget_1.fbon) {
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24
- 25] = bit_set(all_1.ipl[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],30);
}
L7:
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1)
;
if (*(unsigned char *)charq == ' ') {
goto L7;
} else if (*(unsigned char *)charq == '%') {
all_1.iccount = 128;
goto L7;
} else if (*(unsigned char *)charq == 'o') {
/* Ornament in xtuplet. "o" symbol must come AFTER the affected note */
if (comnotes_1.notcrd) {
nole = all_1.nolev[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25];
} else {
nole = 127 & lbit_shift(comtrill_1.icrdat[
comtrill_1.ncrd - 1], (ftnlen)-12);
}
i__2 = all_1.nnl[commvl_1.ivx - 1] - 1;
getorn_(lineq, &all_1.iccount, &all_1.iornq[commvl_1.ivx
+ (all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 1], &
all_1.iornq[commvl_1.ivx - 1], &comget_1.ornrpt, &
comgrace_1.noffseg, &i__2, &commvl_1.ivx, &
c_false, &comnotes_1.notcrd, &nole, (ftnlen)128);
goto L7;
} else if (i_indx("st(){}", charq, (ftnlen)6, (ftnlen)1) > 0)
{
nnlivx = all_1.nnl[commvl_1.ivx - 1] - 1;
if (*(unsigned char *)charq == '(' || *(unsigned char *)
charq == '{') {
/* Detected preslur in xtuplet loop, non-chord note */
++nnlivx;
++comnotes_1.npreslur;
}
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25] = bit_set(
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25],0);
if (*(unsigned char *)charq == 't') {
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25] =
bit_set(all_1.islur[commvl_1.ivx + nnlivx *
24 - 25],1);
}
if (commvl_1.ivx <= all_1.nv) {
kv = 1;
} else {
kv = 2;
}
if (comslur_1.fontslur) {
sslur_(lineq, &all_1.iccount, &all_1.iv, &kv, &nnlivx,
all_1.isdat1, all_1.isdat2, all_1.isdat3, &
all_1.nsdat, &comnotes_1.notcrd, &all_1.nolev[
commvl_1.ivx + nnlivx * 24 - 25], charq, (
ftnlen)128, (ftnlen)1);
} else {
spsslur_(lineq, &all_1.iccount, &all_1.iv, &kv, &
nnlivx, all_1.isdat1, all_1.isdat2,
all_1.isdat3, all_1.isdat4, &all_1.nsdat, &
comnotes_1.notcrd, &all_1.nolev[commvl_1.ivx
+ nnlivx * 24 - 25], charq, (ftnlen)128, (
ftnlen)1);
}
goto L7;
} else if (*(unsigned char *)charq == 'G') {
/* Kluge to get grace in xtup at right location */
--all_1.nnl[commvl_1.ivx - 1];
getgrace_(&commvl_1.ivx, all_1.nnl, lineq, &all_1.iccount,
all_1.islur, all_1.iornq, all_1.ipl,
comnotes_1.ndlev, &comnotes_1.lastlev, &all_1.iv,
&all_1.nv, (ftnlen)128);
++all_1.nnl[commvl_1.ivx - 1];
goto L7;
} else if (*(unsigned char *)charq == *(unsigned char *)
all_1.sq) {
littex_(all_1.islur, &all_1.nnl[commvl_1.ivx - 1], &
commvl_1.ivx, &comas3_1.topmods, lineq, &
all_1.iccount, (ftnlen)128);
goto L7;
} else if (i_indx("0123456789#-nx_", charq, (ftnlen)15, (
ftnlen)1) > 0) {
/* Figure. Must come AFTER the first note of xtup */
ivf = 1;
if (commvl_1.ivx > 1) {
if (comfig_1.ivxfig2 == 0) {
comfig_1.ivxfig2 = commvl_1.ivx;
} else if (commvl_1.ivx != comfig_1.ivxfig2) {
s_wsle(&io___746);
e_wsle();
s_wsle(&io___747);
do_lio(&c__9, &c__1, "Figures not allowed in >1 "
"voice above first", (ftnlen)43);
e_wsle();
s_stop("", (ftnlen)0);
}
ivf = 2;
}
nfig1 = comfig_1.nfigs[ivf - 1] + 1;
getfig_(&comgrace_1.itoff[ivf + (nfig1 << 1) - 3], charq,
lineq, &all_1.iccount, &all_1.isfig[ivf + (
all_1.nnl[commvl_1.ivx - 1] - 1 << 1) - 3], &
comfig_1.itfig[ivf + (nfig1 << 1) - 3], &
all_1.itsofar[commvl_1.ivx - 1], &c__0,
comfig_1.figq + (ivf + (nfig1 << 1) - 3) * 10, &
comfig_1.ivupfig[ivf + (nfig1 << 1) - 3], &
comfig_1.nfigs[ivf - 1], (ftnlen)1, (ftnlen)128, (
ftnlen)10);
goto L7;
} else if (*(unsigned char *)charq == 'X') {
/* Computing MAX */
i__2 = 1, i__3 = all_1.nnl[commvl_1.ivx - 1] - 1;
getx_(lineq, &all_1.iccount, &all_1.irest[commvl_1.ivx +
max(i__2,i__3) * 24 - 25], &comnotes_1.shifton, &
comask_1.wheadpt, &all_1.iornq[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 1], &
commvl_1.ivx, &all_1.irest[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25], &
all_1.itsofar[commvl_1.ivx - 1], &ntup, &itup, &
comnotes_1.nnodur, dotq, &ndoub, (ftnlen)128, (
ftnlen)1);
goto L7;
} else if (*(unsigned char *)charq == 'z') {
/* Chord note in xtup. Goes with *prior* note. */
comnotes_1.notcrd = FALSE_;
++comtrill_1.ncrd;
all_1.ipl[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] - 1)
* 24 - 25] = bit_set(all_1.ipl[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 25],10);
numnum = 0;
/* icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = all_1.nnl[
commvl_1.ivx - 1] - 1;
i__2 = commvl_1.ivx % 16;
setbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__4, &
c__8, &i__2);
if (commvl_1.ivx >= 16) {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],28);
}
comtrill_1.icrdorn[comtrill_1.ncrd - 1] = 0;
/* Get note name */
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (
ftnlen)1);
/* Get optional inputs */
L34:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
/* When chord note is done, will get ' ', making ndx=0, so go past this block */
ndx = i_indx("fsn+-<>12345678reic", durq, (ftnlen)19, (
ftnlen)1);
if (ndx > 0) {
if (ndx <= 3) {
if (! bit_test(comtrill_1.icrdat[comtrill_1.ncrd
- 1],19)) {
comtrill_1.icrdat[comtrill_1.ncrd - 1] =
bit_set(comtrill_1.icrdat[
comtrill_1.ncrd - 1],19);
comtrill_1.icrdat[comtrill_1.ncrd - 1] |= ndx
<< 20;
} else {
comtrill_1.icrdat[comtrill_1.ncrd - 1] =
bit_set(comtrill_1.icrdat[
comtrill_1.ncrd - 1],22);
}
} else if (ndx == 19) {
/* Set flags for cautionary accidental */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],31)
;
all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 1] =
bit_set(all_1.iornq[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 1]
,31);
} else if (ndx <= 7) {
/* +/-/ Check whether octave or accidental shift */
nactmp = 0;
chkpm4ac_(lineq, &all_1.iccount, &nactmp, &moved,
(ftnlen)128);
if (moved) {
/* Transfer accidental shift values */
i__2 = igetbits_(&nactmp, &c__6, &c__4);
setbits_(&comtrill_1.icrdot[comtrill_1.ncrd -
1], &c__6, &c__14, &i__2);
i__2 = igetbits_(&nactmp, &c__7, &c__10);
setbits_(&comtrill_1.icrdot[comtrill_1.ncrd -
1], &c__7, &c__20, &i__2);
} else {
if (*(unsigned char *)durq == '+') {
comnotes_1.lastlev += 7;
} else if (*(unsigned char *)durq == '-') {
comnotes_1.lastlev += -7;
}
}
} else if (*(unsigned char *)durq == 'e') {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],23)
;
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],27);
} else if (*(unsigned char *)durq == 'r') {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],24)
;
all_1.irest[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25] =
bit_set(all_1.irest[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] - 1) * 24 -
25],20);
} else if (*(unsigned char *)durq == 'i') {
/* Midi-only accidental */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],27)
;
} else {
/* must be a number, save it in ioct */
numnum = 1;
ioct = ndx - 7;
}
goto L34;
}
if (numnum == 1) {
comnotes_1.lastlev = ifnolev_(charq, &ioct, &
cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (
ftnlen)1);
} else {
comnotes_1.lastlev = comnotes_1.lastlev - 3 + (
ifnolev_(charq, &c__10, &
cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (
ftnlen)1) - comnotes_1.lastlev + 3) % 7;
}
comtrill_1.icrdat[comtrill_1.ncrd - 1] |=
comnotes_1.lastlev << 12;
for (comnotes_1.npreslur = comnotes_1.npreslur;
comnotes_1.npreslur >= 1; --comnotes_1.npreslur) {
/* Set note level for preslur on chord note in xtup */
setbits_(&all_1.isdat2[all_1.nsdat -
comnotes_1.npreslur], &c__7, &c__19, &
comnotes_1.lastlev);
/* Following lines copied from loop for non-xtup, chord note, preslur */
/* Initially I assigned the slur(s) to next note, so fix. */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_clear(all_1.islur[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],0);
all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx -
1] - 1) * 24 - 25] = bit_set(all_1.islur[
commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] -
1) * 24 - 25],0);
all_1.isdat2[all_1.nsdat - comnotes_1.npreslur] =
bit_set(all_1.isdat2[all_1.nsdat -
comnotes_1.npreslur],0);
i__2 = igetbits_(&all_1.isdat1[all_1.nsdat -
comnotes_1.npreslur], &c__8, &c__3) - 1;
setbits_(&all_1.isdat1[all_1.nsdat -
comnotes_1.npreslur], &c__8, &c__3, &i__2);
/* L41: */
}
goto L7;
} else if (*(unsigned char *)charq == '?') {
/* Arpeggio */
if (bit_test(all_1.ipl[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25],10)) {
/* This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note */
/* of chord, will not set icrdat(25), but iornq(27) */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],25);
} else {
all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx -
1] - 1) * 24 - 1] = bit_set(all_1.iornq[
commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] -
1) * 24 - 1],27);
}
/* Check for shift */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ' ') {
--all_1.iccount;
} else {
/* durq must be "-" */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
--all_1.iccount;
/* record the shift */
++comarpshift_1.numarpshift;
comarpshift_1.ivarpshift[comarpshift_1.numarpshift -
1] = commvl_1.ivx;
comarpshift_1.iparpshift[comarpshift_1.numarpshift -
1] = all_1.nnl[commvl_1.ivx - 1] - 1;
comarpshift_1.arpshift[comarpshift_1.numarpshift - 1]
= fnum;
}
goto L7;
} else if (*(unsigned char *)charq == 'D') {
i__2 = all_1.nnl[commvl_1.ivx - 1] - 1;
getdyn_(&commvl_1.ivx, &i__2, &all_1.irest[commvl_1.ivx +
(all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 25], &
all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 1], lineq, &
all_1.iccount, (ftnlen)128);
goto L7;
/* +++ */
} else if (*(unsigned char *)charq == ']') {
/* Multiplicity up-down, must have '][ ' */
all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] -
1) * 24 - 25] = bit_set(all_1.islur[commvl_1.ivx
+ (all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 25],20)
;
all_1.iccount += 2;
goto L7;
/* c+++ */
}
/* End of loop for xtup options. If here, charq must be a (non-crd) note name. */
/* or rest */
if (*(unsigned char *)charq == 'r') {
/* Rest in xtup */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.irest[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],0);
i__2 = all_1.iccount;
if (i_indx("+-b", lineq + i__2, (ftnlen)3, all_1.iccount
+ 1 - i__2) > 0) {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == 'b') {
/* Blank rest in middle of xtup */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.islur[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],29);
} else {
/* Override height of embedded xtup rest */
ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) -
2;
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (
ftnlen)128, (ftnlen)1);
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = ipm * i_nint(&fnum) +
100;
--all_1.iccount;
}
} else if (commvl_1.ivx <= all_1.nv) {
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = 0;
} else {
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = 2;
}
}
comnotes_1.notcrd = TRUE_;
L8:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
if (i_indx("+-<>", durq, (ftnlen)4, (ftnlen)1) > 0) {
/* Accidental horizontal shift */
chkpm4ac_(lineq, &all_1.iccount, &all_1.nacc[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25], &moved, (ftnlen)128);
if (! moved) {
if (*(unsigned char *)durq == '+') {
comnotes_1.lastlev += 7;
} else if (*(unsigned char *)durq == '-') {
comnotes_1.lastlev += -7;
}
}
} else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0)
{
if (all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] == 0) {
/* No accid set yet */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = i_indx("fsn", durq, (
ftnlen)3, (ftnlen)1);
} else {
/* Symbol must be repeated, so it's a double */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.nacc[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],2);
}
} else if (*(unsigned char *)durq == 'i') {
/* Set flag for midi-only accidental */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.nacc[commvl_1.ivx
+ all_1.nnl[commvl_1.ivx - 1] * 24 - 25],17);
} else if (*(unsigned char *)durq == 'c') {
/* Set flags for cautionary accidental */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],31);
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 1] = bit_set(all_1.iornq[commvl_1.ivx
+ all_1.nnl[commvl_1.ivx - 1] * 24 - 1],31);
} else if (i_indx("ul", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Force stem direction for non-beamed xtup note */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.islur[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],30);
if (*(unsigned char *)durq == 'u') {
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.islur[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],17);
}
} else if (*(unsigned char *)durq == 'e') {
/* Left-shift main xtup note */
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.ipl[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],8);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],27);
} else if (*(unsigned char *)durq == 'r') {
/* Right-shift main xtup note */
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = bit_set(all_1.ipl[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],9);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],20);
} else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double an xtup note to make an unequal xtup */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.nacc[commvl_1.ivx
+ all_1.nnl[commvl_1.ivx - 1] * 24 - 25],18);
if (*(unsigned char *)durq == 'F') {
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25] = bit_set(all_1.nacc[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],19);
}
++ndoub;
} else if (*(unsigned char *)durq == 'd') {
/* Dotted xtup note */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = bit_set(all_1.nacc[commvl_1.ivx
+ all_1.nnl[commvl_1.ivx - 1] * 24 - 25],27);
} else {
/* Must be an octave number */
i__2 = *(unsigned char *)durq - 48;
comnotes_1.lastlev = ifnolev_(charq, &i__2, &
cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (
ftnlen)1);
}
goto L8;
}
if (itup < ntup) {
/* Last note is handled *after* flowing out of the xtup if block, but still */
/* within block for a note-rest. Set note level now (rest already done). */
/* Could have problem here if rests & doubled notes are combined in xtup, */
/* since might exit the loop at the wrong place. Worry about it later. */
if (! bit_test(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],0)) {
comnotes_1.lastlev = comnotes_1.lastlev - 3 + (
ifnolev_(charq, &c__10, &
cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (
ftnlen)1) - comnotes_1.lastlev + 3) % 7;
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25] = comnotes_1.lastlev;
}
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] = 0;
for (comnotes_1.npreslur = comnotes_1.npreslur;
comnotes_1.npreslur >= 1; --comnotes_1.npreslur) {
/* Set note level for preslur on internal xtup note */
setbits_(&all_1.isdat2[all_1.nsdat -
comnotes_1.npreslur], &c__7, &c__19, &
comnotes_1.lastlev);
/* L42: */
}
}
if (itup == ntup - ndoub) {
goto L12;
}
/* L6: */
}
L12:
if (comget_1.ornrpt) {
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
1] |= all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 1] & 10026991;
if ((all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 1] & 32896) > 0) {
/* This is a trill (bit 7 or 15) so must dup the parameters */
++comtrill_1.ntrill;
comtrill_1.ivtrill[comtrill_1.ntrill - 1] = commvl_1.ivx;
comtrill_1.iptrill[comtrill_1.ntrill - 1] = all_1.nnl[
commvl_1.ivx - 1];
comtrill_1.xnsktr[comtrill_1.ntrill - 1] =
comtrill_1.xnsktr[comtrill_1.ntrill - 2];
}
}
/* End of if-block for xtuplet input */
} else if (*(unsigned char *)durq == 'm') {
/* Multi-bar rest: next 1 or two digits are # of bars. */
/* For some purposes, pretend its one bar only */
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= all_1.lenbar;
comgrace_1.ibarmbr = all_1.nbars + 1;
comgrace_1.mbrest = 0;
comgrace_1.xb4mbr = 0.f;
L20:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq >= 48 && *(unsigned char *)durq <= 57)
{
comgrace_1.mbrest = comgrace_1.mbrest * 10 + *(unsigned char *
)durq - 48;
goto L20;
}
} else if (i_indx("ul", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Set stem flipper */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],30);
if (*(unsigned char *)durq == 'u') {
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],17);
}
goto L2;
} else if (*(unsigned char *)durq == 'a') {
/* "Alone", i.e., prohibit beam */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],18);
goto L2;
} else if (*(unsigned char *)durq == 'r') {
/* Right offset by one notehead */
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 25],9);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],20);
goto L2;
} else if (*(unsigned char *)durq == 'e') {
/* Left offset by one notehead */
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 25],8);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],27);
goto L2;
} else if (*(unsigned char *)durq == 'S') {
/* Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 */
/* Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to */
/* interbeams = internotes*2/3. */
all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],27);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ':') {
/* End stickyS. Grab data now from prior note, since we have to shut off stickyS. */
i__1 = igetbits_(&all_1.mult[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25], &c__3, &c__28);
setbits_(&all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 25], &c__3, &c__28, &i__1);
comget_1.stickys = FALSE_;
goto L2;
}
/* If durq .ne. ':' then iccount is now on the start of the number */
readnum_(lineq, &all_1.iccount, durq, &dum, (ftnlen)128, (ftnlen)
1);
r__1 = (dum - .5f) * 2;
i__1 = i_nint(&r__1);
setbits_(&all_1.mult[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25], &c__3, &c__28, &i__1);
if (*(unsigned char *)durq == ':') {
comget_1.stickys = TRUE_;
} else {
--all_1.iccount;
}
goto L2;
} else if (*(unsigned char *)durq == ',') {
/* 2:1 pattern */
idotform = 3;
/* Now flow to duration setting, as if durq=' ' */
} else if (*(unsigned char *)durq == '.') {
/* Dotted pattern. Close out note. Mult time by 3/4. */
/* Set time for next note to 1/4. Start the note. */
idotform = 1;
} else if (*(unsigned char *)durq == 'o') {
/* Suppress rest centering */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],25);
goto L2;
} else if (*(unsigned char *)durq == 'L') {
/* With keyboard rest option, look left */
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 1] =
bit_set(all_1.iornq[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 1],30);
goto L2;
} else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Double note for xtup. Must check here in case "D" came before "x" or on */
/* last note of xtup. Need to flag it in pmxa since affects horiz. spacing. */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],18);
if (*(unsigned char *)durq == 'F') {
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],19);
}
goto L2;
} else if (*(unsigned char *)durq == 'A') {
/* Accidental option */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'o') {
/* Ordered accidentals in a chord. Mark the main note. */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],28);
} else {
/* Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],29);
--all_1.iccount;
}
goto L2;
} else if (*(unsigned char *)durq != ' ') {
s_wsle(&io___752);
do_lio(&c__9, &c__1, "Illegal character in note: ", (ftnlen)27);
do_lio(&c__9, &c__1, durq, (ftnlen)1);
do_lio(&c__9, &c__1, ", ivx,nn:", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&commvl_1.ivx, (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&all_1.nnl[commvl_1.ivx - 1], (
ftnlen)sizeof(integer));
e_wsle();
stop1_();
}
/* Done with note/rest options. Set level and duration. */
if (! bit_test(all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1]
* 24 - 25],0)) {
if (numnum == 2) {
comnotes_1.lastlev = ifnolev_(charq, &ioct, &
cominsttrans_1.itransamt[cominsttrans_1.instno[
all_1.iv - 1] - 1], (ftnlen)1);
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = comnotes_1.lastlev;
} else {
comnotes_1.lastlev = comnotes_1.lastlev - 3 + (ifnolev_(charq,
&c__10, &cominsttrans_1.itransamt[
cominsttrans_1.instno[all_1.iv - 1] - 1], (ftnlen)1)
- comnotes_1.lastlev + 3) % 7;
all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = comnotes_1.lastlev;
}
for (comnotes_1.npreslur = comnotes_1.npreslur;
comnotes_1.npreslur >= 1; --comnotes_1.npreslur) {
/* Set level for preslur on normal note, non-chord */
setbits_(&all_1.isdat2[all_1.nsdat - comnotes_1.npreslur], &
c__7, &c__19, &comnotes_1.lastlev);
/* L43: */
}
}
if (idotform > 0) {
if (idotform == 1) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = ifnodur_(&comnotes_1.nnodur, dotq, (ftnlen)1) *
3 / 2;
} else if (idotform == 2) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = all_1.nodur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25] / 3;
} else if (idotform == 3) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = ifnodur_(&comnotes_1.nnodur, dotq, (ftnlen)1);
} else if (idotform == 4) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = all_1.nodur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] - 1) * 24 - 25] / 2;
}
} else if (bit_test(all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],19)) {
/* Set duration of full-bar rest as pause */
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= all_1.lenbar;
/* Use a one-line function to set nnodur. It gives inverse of ifnodur. */
i__1 = (integer) (log(all_1.lenbar + .1f) / .69315f) + 48;
chax_(ch__1, (ftnlen)1, &i__1);
comnotes_1.nnodur = i_indx("62514x0x37", ch__1, (ftnlen)10, (
ftnlen)1) - 1;
} else if (comgrace_1.ibarmbr != all_1.nbars + 1) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= ifnodur_(&comnotes_1.nnodur, dotq, (ftnlen)1);
if (bit_test(all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx -
1] * 24 - 25],3)) {
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = all_1.nodur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25] * 7 / 6;
}
}
if (comnotes_1.shifton && ! bit_test(all_1.irest[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25],16)) {
/* Shift is on, and this is not first shifted note. Check for duration change */
if (all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] != all_1.nodur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx
- 1] - 1) * 24 - 25]) {
/* Must stop and restart the offset. */
all_1.irest[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] - 1) *
24 - 25] = bit_set(all_1.irest[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] - 1) * 24 - 25],17);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],16);
++comudsp_1.nudoff[commvl_1.ivx - 1];
comudsp_1.udoff[commvl_1.ivx + comudsp_1.nudoff[commvl_1.ivx
- 1] * 24 - 25] = comudsp_1.udoff[commvl_1.ivx + (
comudsp_1.nudoff[commvl_1.ivx - 1] - 1) * 24 - 25];
}
}
all_1.itsofar[commvl_1.ivx - 1] += all_1.nodur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25];
if (comfb_1.autofbon && comfb_1.tautofb > comtol_1.tol &&
comget_1.fbon) {
/* Check to see if need to terminate auto forced beam */
r__1 = all_1.itsofar[commvl_1.ivx - 1] - comfb_1.t1autofb;
if (r_mod(&r__1, &comfb_1.tautofb) < comtol_1.tol) {
/* Terminate autofb */
comfb_1.t2fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1] *
24 - 25] = (real) all_1.itsofar[commvl_1.ivx - 1];
comget_1.fbon = FALSE_;
}
}
if ((all_1.itsofar[commvl_1.ivx - 1] - all_1.lenb0) % all_1.lenbar ==
0) {
/* Finished a bar */
++all_1.nbars;
all_1.nib[commvl_1.ivx + all_1.nbars * 24 - 25] = all_1.nnl[
commvl_1.ivx - 1];
if (all_1.firstgulp && all_1.lenb0 != 0 && all_1.nbars == 1) {
/* Just finished the pickup bar for this voice. */
all_1.lenbar = all_1.lenb1;
}
}
if (idotform == 1) {
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
idotform = 2;
numnum = 1;
goto L28;
} else if (idotform == 3) {
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
idotform = 4;
numnum = 1;
goto L28;
}
/* End of sub block for note-rest */
} else if (*(unsigned char *)charq == 'z') {
/* Chord note. Must have note name, may have octave#,+,-,s,f,n,d */
/* Actually the 'd' is not used, since time value comes from */
/* basic note. Unless dot is to be shifted! */
/* Doesn't increase # of notes, so must handle separately */
/* ncrd: index of crd */
/* Set bit 10 of ipl on main note as flag */
/* Bits in icrdat: */
/* 0-7 ip within voice */
/* 8-11 ivx */
/* 12-18 note level */
/* 19 accidental? */
/* 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) */
/* 23 shift left */
/* 24 shift right */
/* 25 arpeggio start or stop */
/* 26 flag for moved dot (here, not icrdot, since this is always reset!) */
/* 27 Midi-only accidental */
/* 29 Tag for accidental shift...means add to autoshifts. */
/* 31 Cautionary accidental */
/* Bits in icrdot: */
/* 0-6 10*abs(vertical dot shift in \internote) + 64 */
/* 7-13 10*abs(horizontal dot shift in \internote) + 64 */
/* 14-19 vert accidental shift-32 */
/* 20-26 20*(horiz accidental shift+3.2) */
/* 27-29 top-down level rank of chord note w/accid. Set in crdaccs. */
/* Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. */
++comtrill_1.ncrd;
all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],10);
numnum = 0;
/* icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = all_1.nnl[commvl_1.ivx - 1];
i__1 = commvl_1.ivx % 16;
setbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__4, &c__8, &i__1)
;
if (commvl_1.ivx >= 16) {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],28);
}
comtrill_1.icrdot[comtrill_1.ncrd - 1] = 0;
comtrill_1.icrdorn[comtrill_1.ncrd - 1] = 0;
/* Get note name */
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
/* Get optional inputs */
L25:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* ndx = index('fsn+-<>12345678rediA',durq) */
ndx = i_indx("fsn+-<>12345678rediAc", durq, (ftnlen)21, (ftnlen)1);
if (ndx == 20) {
/* Expect +|-|<|> , set tag, loop */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],29);
goto L25;
} else if (ndx > 0) {
if (ndx <= 3) {
if (! bit_test(comtrill_1.icrdat[comtrill_1.ncrd - 1],19)) {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],19);
comtrill_1.icrdat[comtrill_1.ncrd - 1] |= ndx << 20;
} else {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],22);
}
} else if (ndx == 21) {
/* Set flags for cautionary accidental */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],31);
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
1] = bit_set(all_1.iornq[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 1],31);
} else if (ndx <= 7) {
/* +/-/ Check whether octave or accidental shift */
nactmp = 0;
chkpm4ac_(lineq, &all_1.iccount, &nactmp, &moved, (ftnlen)128)
;
if (moved) {
/* Transfer accidental shift values */
i__1 = igetbits_(&nactmp, &c__6, &c__4);
setbits_(&comtrill_1.icrdot[comtrill_1.ncrd - 1], &c__6, &
c__14, &i__1);
i__1 = igetbits_(&nactmp, &c__7, &c__10);
setbits_(&comtrill_1.icrdot[comtrill_1.ncrd - 1], &c__7, &
c__20, &i__1);
} else {
if (*(unsigned char *)durq == '+') {
comnotes_1.lastlev += 7;
} else if (*(unsigned char *)durq == '-') {
comnotes_1.lastlev += -7;
}
}
} else if (*(unsigned char *)durq == 'e') {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],23);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],27);
} else if (*(unsigned char *)durq == 'r') {
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],24);
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],20);
} else if (*(unsigned char *)durq == 'i') {
/* Midi-only accidental on chord note */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],27);
} else if (*(unsigned char *)durq == 'd') {
/* Must keep 'd' optional (backward compatibility), unless it is moved! */
i__1 = all_1.iccount;
if (i_indx("+-", lineq + i__1, (ftnlen)2, all_1.iccount + 1 -
i__1) > 0) {
/* move a dot, unless next char is not part of a number */
i__1 = all_1.iccount + 1;
if (i_indx("0123456789.", lineq + i__1, (ftnlen)11,
all_1.iccount + 2 - i__1) == 0) {
goto L25;
}
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],26);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
++all_1.iccount;
readnum_(lineq, &all_1.iccount, dumq, &fnum, (ftnlen)128,
(ftnlen)1);
if (*(unsigned char *)durq == '+') {
r__1 = fnum * 10;
comtrill_1.icrdot[comtrill_1.ncrd - 1] |= i_nint(&
r__1) + 64;
} else {
r__1 = fnum * 10;
comtrill_1.icrdot[comtrill_1.ncrd - 1] |= -i_nint(&
r__1) + 64;
}
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
/* Vertical shift specified also */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)
128, (ftnlen)1);
if (*(unsigned char *)dumq == '+') {
r__1 = fnum * 10;
ifnum = i_nint(&r__1) + 64;
} else {
r__1 = fnum * 10;
ifnum = -i_nint(&r__1) + 64;
}
} else {
ifnum = 64;
}
comtrill_1.icrdot[comtrill_1.ncrd - 1] |= ifnum << 7;
--all_1.iccount;
}
} else {
/* must be a single digit, save it in ioct */
numnum = 1;
ioct = ndx - 7;
}
goto L25;
}
if (numnum == 1) {
comnotes_1.lastlev = ifnolev_(charq, &ioct, &
cominsttrans_1.itransamt[cominsttrans_1.instno[all_1.iv -
1] - 1], (ftnlen)1);
} else {
comnotes_1.lastlev = comnotes_1.lastlev - 3 + (ifnolev_(charq, &
c__10, &cominsttrans_1.itransamt[cominsttrans_1.instno[
all_1.iv - 1] - 1], (ftnlen)1) - comnotes_1.lastlev + 3) %
7;
}
comtrill_1.icrdat[comtrill_1.ncrd - 1] |= comnotes_1.lastlev << 12;
for (comnotes_1.npreslur = comnotes_1.npreslur; comnotes_1.npreslur >=
1; --comnotes_1.npreslur) {
setbits_(&all_1.isdat2[all_1.nsdat - comnotes_1.npreslur], &c__7,
&c__19, &comnotes_1.lastlev);
/* Set level for chord note. */
/* Initially I assigned the slur(s) to next note, so fix. */
all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 25] = bit_clear(all_1.islur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 25],0);
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],0);
all_1.isdat2[all_1.nsdat - comnotes_1.npreslur] = bit_set(
all_1.isdat2[all_1.nsdat - comnotes_1.npreslur],0);
i__1 = igetbits_(&all_1.isdat1[all_1.nsdat - comnotes_1.npreslur],
&c__8, &c__3) - 1;
setbits_(&all_1.isdat1[all_1.nsdat - comnotes_1.npreslur], &c__8,
&c__3, &i__1);
/* L44: */
}
if (comnotes_1.notcrd) {
/* This is the first chord note in this chord. */
/* Computing MIN */
i__1 = all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25];
comtrill_1.minlev = min(i__1,comnotes_1.lastlev);
/* Computing MAX */
i__1 = all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25];
comtrill_1.maxlev = max(i__1,comnotes_1.lastlev);
} else {
comtrill_1.minlev = min(comtrill_1.minlev,comnotes_1.lastlev);
comtrill_1.maxlev = max(comtrill_1.maxlev,comnotes_1.lastlev);
}
comnotes_1.notcrd = FALSE_;
} else if (*(unsigned char *)charq == 'G') {
getgrace_(&commvl_1.ivx, all_1.nnl, lineq, &all_1.iccount,
all_1.islur, all_1.iornq, all_1.ipl, comnotes_1.ndlev, &
comnotes_1.lastlev, &all_1.iv, &all_1.nv, (ftnlen)128);
/* Grace, comes *before* main note: */
/* UNLESS there's an 'A' or 'W' after the 'G' */
/* ngrace = # of grace note groups so far in block */
/* ivg(ngrace), ipg(ngrace) */
/* nng(ngrace) = # of notes in this group: default = 1 */
/* ngstrt(ngrace) = starting position in nolevg of levels for this grace */
/* multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' */
/* upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' */
/* slurg(ngrace) = logical for slur; default F, input 's' */
/* slashg(ngrace) = T if slash; default is F, input 'x' */
/* These data MUST precede note name of first note */
/* nolevg, naccg: lists of levels and accid's, indexed as described above. */
/* ngrace = ngrace+1 */
/* ivg(ngrace) = ivx */
/* ipg(ngrace) = nnl(ivx)+1 */
/* if (ngrace .eq. 1) then */
/* ngstrt(ngrace) = 1 */
/* else */
/* ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) */
/* end if */
/* islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) */
/* nng(ngrace) = 1 */
/* multg(ngrace) = 1 */
/* upg(ngrace) = .true. */
/* slurg(ngrace) = .false. */
/* slashg(ngrace) = .false. */
/* 18 call getchar(lineq,iccount,charq) */
/* if (index('WA',charq) .gt. 0) then */
/* c */
/* c Grace is on note that was already done, so shift flags forward one note. */
/* c This puts flag on actual note with grace; later for W will go ahead one more. */
/* c */
/* ipg(ngrace) = nnl(ivx) */
/* islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) */
/* islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) */
/* if (slurg(ngrace)) */
/* * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) */
/* if (charq .eq. 'A') then */
/* c */
/* c close After, clear way-after bit, to ensure priority of most recent A/W */
/* c */
/* ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) */
/* else */
/* c */
/* c Way after; later assign to following note, and position like normal grace. */
/* c */
/* ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) */
/* end if */
/* else if (charq .eq. 'm') then */
/* call getchar(lineq,iccount,charq) */
/* multg(ngrace) = ichar(charq)-48 */
/* else if (index('123456789',charq) .gt. 0) then */
/* call readnum(lineq,iccount,durq,fnum) */
/* iccount = iccount-1 */
/* nng(ngrace) = nint(fnum) */
/* else if (charq .eq. 'l') then */
/* upg(ngrace) = .false. */
/* else if (charq .eq. 's') then */
/* slurg(ngrace) = .true. */
/* if (nnl(ivx) .gt. 0) then */
/* c */
/* c If A- or W-grace, set signal to start slur on main note. */
/* c */
/* if(btest(ipl(ivx,nnl(ivx)),31) .or. */
/* * btest(ipl(ivx,nnl(ivx)),29)) */
/* * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) */
/* end if */
/* else if (charq .eq. 'x') then */
/* slashg(ngrace) = .true. */
/* else if (charq .eq. 'u') then */
/* else if (charq .eq. 'X') then */
/* c */
/* c Space before main note of grace. Number will come next. */
/* c */
/* iccount = iccount+1 */
/* call readnum(lineq,iccount,durq,graspace(ngrace)) */
/* iccount = iccount-1 */
/* end if */
/* if (index('abcdefg',charq) .eq. 0) go to 18 */
/* c */
/* c At this point, charq is first note name in grace */
/* c */
/* do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 */
/* naccg(ing) = 0 */
/* ioct = 0 */
/* if (ing .gt. ngstrt(ngrace)) then */
/* 55 call getchar(lineq,iccount,charq) */
/* if (charq .eq. ' ') go to 55 */
/* endif */
/* iclastlev = 0 */
/* 9 call getchar(lineq,iccount,durq) */
/* if (durq .ne. ' ') then */
/* if (durq.eq.'+') then */
/* lastlev = lastlev+7 */
/* iclastlev = iclastlev+7 */
/* else if (durq.eq.'-') then */
/* lastlev = lastlev-7 */
/* iclastlev = iclastlev-7 */
/* else if (index('fsn',durq) .gt. 0) then */
/* if (naccg(ing) .eq. 0) then */
/* naccg(ing) = index('fsn',durq) */
/* else */
/* c */
/* c Double accidental */
/* c */
/* naccg(ing) = ibset(naccg(ing),2) */
/* end if */
/* else */
/* ioct = ichar(durq)-48 */
/* end if */
/* go to 9 */
/* end if */
/* if (ioct .gt. 0) then */
/* lastlev = ifnolev(charq,ioct) */
/* else */
/* if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then */
/* if (ivx .le. nv) then */
/* kv = 1 */
/* else */
/* kv = 2 */
/* end if */
/* lastlev = ndlev(iv,kv)+iclastlev */
/* end if */
/* lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) */
/* end if */
/* nolevg(ing) = lastlev */
/* 19 continue */
/* c */
/* c Grace could come before first note of block, so reset end level. */
/* c */
/* if (nnl(ivx).eq.0) then */
/* if (ivx .le. nv) then */
/* kv = 1 */
/* else */
/* kv = 2 */
/* end if */
/* ndlev(iv,kv) = lastlev */
/* end if */
} else if (*(unsigned char *)charq == *(unsigned char *)all_1.sq) {
/* Literal TeX string */
i__1 = all_1.nnl[commvl_1.ivx - 1] + 1;
littex_(all_1.islur, &i__1, &commvl_1.ivx, &comas3_1.topmods, lineq, &
all_1.iccount, (ftnlen)128);
} else if (*(unsigned char *)charq == 'o') {
/* Ornament on non-xtup note. Symbol must come AFTER the affected note */
if (comnotes_1.notcrd) {
nole = all_1.nolev[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25];
} else {
nole = 127 & lbit_shift(comtrill_1.icrdat[comtrill_1.ncrd - 1], (
ftnlen)-12);
}
getorn_(lineq, &all_1.iccount, &all_1.iornq[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 1], &all_1.iornq[commvl_1.ivx - 1], &
comget_1.ornrpt, &comgrace_1.noffseg, &all_1.nnl[commvl_1.ivx
- 1], &commvl_1.ivx, &c_true, &comnotes_1.notcrd, &nole, (
ftnlen)128);
} else if (i_indx("st(){}", charq, (ftnlen)6, (ftnlen)1) > 0) {
nnlivx = all_1.nnl[commvl_1.ivx - 1];
if (*(unsigned char *)charq == '(' || *(unsigned char *)charq == '{')
{
/* Detect preslur on normal non-chord note */
++nnlivx;
++comnotes_1.npreslur;
}
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25] = bit_set(all_1.islur[
commvl_1.ivx + nnlivx * 24 - 25],0);
if (*(unsigned char *)charq == 't') {
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25] = bit_set(
all_1.islur[commvl_1.ivx + nnlivx * 24 - 25],1);
}
if (commvl_1.ivx <= all_1.nv) {
kv = 1;
} else {
kv = 2;
}
if (comslur_1.fontslur) {
sslur_(lineq, &all_1.iccount, &all_1.iv, &kv, &nnlivx,
all_1.isdat1, all_1.isdat2, all_1.isdat3, &all_1.nsdat, &
comnotes_1.notcrd, &all_1.nolev[commvl_1.ivx + nnlivx *
24 - 25], charq, (ftnlen)128, (ftnlen)1);
} else {
spsslur_(lineq, &all_1.iccount, &all_1.iv, &kv, &nnlivx,
all_1.isdat1, all_1.isdat2, all_1.isdat3, all_1.isdat4, &
all_1.nsdat, &comnotes_1.notcrd, &all_1.nolev[
commvl_1.ivx + nnlivx * 24 - 25], charq, (ftnlen)128, (
ftnlen)1);
}
} else if (*(unsigned char *)charq == '?') {
/* Arpeggio */
if (bit_test(all_1.ipl[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25],10)) {
/* This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note */
/* of chord, will not set icrdat(25), but iornq(27) */
comtrill_1.icrdat[comtrill_1.ncrd - 1] = bit_set(
comtrill_1.icrdat[comtrill_1.ncrd - 1],25);
} else {
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 1] =
bit_set(all_1.iornq[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 1],27);
}
/* Check for shift */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ' ') {
--all_1.iccount;
} else {
/* durq must be "-" */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
--all_1.iccount;
/* record the shift */
++comarpshift_1.numarpshift;
comarpshift_1.ivarpshift[comarpshift_1.numarpshift - 1] =
commvl_1.ivx;
comarpshift_1.iparpshift[comarpshift_1.numarpshift - 1] =
all_1.nnl[commvl_1.ivx - 1];
comarpshift_1.arpshift[comarpshift_1.numarpshift - 1] = fnum;
}
} else if (i_indx("0123456789#-nx_", charq, (ftnlen)15, (ftnlen)1) > 0) {
/* We have a figure. Must come AFTER the note it goes under */
ivf = 1;
if (commvl_1.ivx > 1) {
if (comfig_1.ivxfig2 == 0) {
comfig_1.ivxfig2 = commvl_1.ivx;
} else if (commvl_1.ivx != comfig_1.ivxfig2) {
s_wsle(&io___754);
e_wsle();
s_wsle(&io___755);
do_lio(&c__9, &c__1, "Figures not allowed in >1 voice above "
"first", (ftnlen)43);
e_wsle();
s_stop("", (ftnlen)0);
}
ivf = 2;
}
nfig1 = comfig_1.nfigs[ivf - 1] + 1;
getfig_(&comgrace_1.itoff[ivf + (nfig1 << 1) - 3], charq, lineq, &
all_1.iccount, &all_1.isfig[ivf + (all_1.nnl[commvl_1.ivx - 1]
<< 1) - 3], &comfig_1.itfig[ivf + (nfig1 << 1) - 3], &
all_1.itsofar[commvl_1.ivx - 1], &all_1.nodur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25], comfig_1.figq + (ivf
+ (nfig1 << 1) - 3) * 10, &comfig_1.ivupfig[ivf + (nfig1 << 1)
- 3], &comfig_1.nfigs[ivf - 1], (ftnlen)1, (ftnlen)128, (
ftnlen)10);
} else if (*(unsigned char *)charq == '[') {
/* Start forced beam. Record barno & time since start of inp. blk. Set signal */
++comfb_1.nfb[commvl_1.ivx - 1];
comget_1.fbon = TRUE_;
*(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx + comfb_1.nfb[
commvl_1.ivx - 1] * 24 - 25] = 'x';
comfb_1.t1fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1] * 24 - 25] =
(real) all_1.itsofar[commvl_1.ivx - 1];
nadj = 0;
if (comfb_1.autofbon) {
comfb_1.autofbon = FALSE_;
}
L17:
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("ulf", charq, (ftnlen)3, (ftnlen)1) > 0) {
*(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx + comfb_1.nfb[
commvl_1.ivx - 1] * 24 - 25] = *(unsigned char *)charq;
goto L17;
} else if (*(unsigned char *)charq == 'j') {
/* Continuing a jumped beam here */
all_1.irest[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 25] = bit_set(all_1.irest[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 25],24);
/* Set flag to watch for END of this forced beam, so can set flag rest(30) on */
/* NEXT note as signal to start a new notes group there. */
combjmp_1.isbj2 = TRUE_;
goto L17;
} else if (*(unsigned char *)charq == 'h') {
all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 25] = bit_set(all_1.islur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 25],2);
goto L17;
} else if (*(unsigned char *)charq == 'm') {
/* Force multiplicity. Next input is digit */
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 25] = bit_set(all_1.islur[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 25],21);
i__1 = *(unsigned char *)charq - 48;
setbits_(&all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1]
+ 1) * 24 - 25], &c__3, &c__22, &i__1);
goto L17;
} else if (*(unsigned char *)charq == ':') {
/* Start auto forced beam pattern */
comfb_1.autofbon = TRUE_;
/* When forced later beam ends, check whether tautofv <=0; if so set it. */
comfb_1.tautofb = (real) (-all_1.itsofar[commvl_1.ivx - 1]);
comfb_1.t1autofb = (real) all_1.itsofar[commvl_1.ivx - 1];
goto L17;
} else if (*(unsigned char *)charq != ' ') {
/* Must be '+/-' for height or slope shift */
++nadj;
/* nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
--all_1.iccount;
iadj = i_nint(&fnum);
if (*(unsigned char *)charq == '-') {
iadj = -iadj;
}
if (nadj == 1) {
/* This is a level shift. Note if 0 was entered, iadj = 30 */
i__1 = iadj + 30;
setbits_(&all_1.ipl[commvl_1.ivx + (all_1.nnl[commvl_1.ivx -
1] + 1) * 24 - 25], &c__6, &c__11, &i__1);
} else if (nadj == 2) {
/* Must be a slope shift */
i__1 = iadj + 30;
setbits_(&all_1.ipl[commvl_1.ivx + (all_1.nnl[commvl_1.ivx -
1] + 1) * 24 - 25], &c__6, &c__17, &i__1);
} else {
/* Beam-thk fine tune */
setbits_(&all_1.islur[commvl_1.ivx + (all_1.nnl[commvl_1.ivx
- 1] + 1) * 24 - 25], &c__2, &c__27, &iadj);
}
goto L17;
}
} else if (*(unsigned char *)charq == ']') {
if (comfb_1.autofbon && comfb_1.tautofb < comtol_1.tol) {
comfb_1.tautofb = all_1.itsofar[commvl_1.ivx - 1] +
comfb_1.tautofb;
}
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("j ", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Since ']' comes AFTER note, itsofar has been updated. Set ending signal. */
comfb_1.t2fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1] * 24 -
25] = (real) all_1.itsofar[commvl_1.ivx - 1];
comget_1.fbon = FALSE_;
if (*(unsigned char *)charq == 'j') {
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
25] = bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],23);
}
if (combjmp_1.isbj2) {
/* This is the end of a fb segment of a jump beam. Set flag on NEXT note to */
/* force start of new notes group, provided this is not last note in bar. */
if (all_1.itsofar[commvl_1.ivx - 1] % all_1.lenbar != 0) {
all_1.irest[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] +
1) * 24 - 25] = bit_set(all_1.irest[commvl_1.ivx
+ (all_1.nnl[commvl_1.ivx - 1] + 1) * 24 - 25],30)
;
}
combjmp_1.isbj2 = FALSE_;
}
} else if (*(unsigned char *)charq == '[') {
/* Multiplicity down-up signal */
all_1.islur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.islur[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],20);
} else if (*(unsigned char *)charq == '-') {
/* Set signals for gap in single-slope beam [...]-[...] */
all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25] =
bit_set(all_1.nacc[commvl_1.ivx + all_1.nnl[commvl_1.ivx
- 1] * 24 - 25],20);
all_1.nacc[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 25] = bit_set(all_1.nacc[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 25],21);
/* Next two characters must be "[ ". Skip over them. */
all_1.iccount += 2;
}
} else if (*(unsigned char *)charq == 'D') {
getdyn_(&commvl_1.ivx, &all_1.nnl[commvl_1.ivx - 1], &all_1.irest[
commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25], &
all_1.iornq[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 -
1], lineq, &all_1.iccount, (ftnlen)128);
} else if (*(unsigned char *)charq == 'h') {
/* Heading or height. For heading, only OK if at start of block */
/* Check whether at beginning of a block */
if (all_1.iv != 1 || all_1.nnl[0] != 0) {
s_wsle(&io___758);
do_lio(&c__9, &c__1, "You entered \"h\" not at beginning of block"
, (ftnlen)41);
e_wsle();
stop1_();
}
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
comhead_1.ihdvrt = 0;
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Vertical offset */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, charq, &fnum, (ftnlen)128, (
ftnlen)1);
comhead_1.ihdvrt = fnum + .1f;
if (*(unsigned char *)durq == '-') {
comhead_1.ihdvrt = -comhead_1.ihdvrt;
}
*(unsigned char *)durq = *(unsigned char *)charq;
}
if (*(unsigned char *)durq != ' ') {
/* Height symbol. Read past (until next blank) */
L3:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
goto L3;
}
} else {
/* Set flag for header & read it in */
comhead_1.ihdht = 16;
getbuf_(comhead_1.headrq, (ftnlen)80);
all_1.iccount = 128;
}
} else if (*(unsigned char *)charq == 'L') {
/* Linebreak, already handled in pmxa, but check for movement break */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fmovbrk, (ftnlen)128, (ftnlen)
1);
if (*(unsigned char *)durq == 'P') {
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
}
if (*(unsigned char *)durq == 'M') {
comget_1.movbrk = i_nint(&fmovbrk);
comget_1.movgap = 0;
comget_1.parmov = -1.f;
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
L31:
if (*(unsigned char *)durq == '+') {
/* Get vertical space (\internotes) */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
comget_1.movgap = i_nint(&fnum);
goto L31;
} else if (*(unsigned char *)durq == 'i') {
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &comget_1.parmov, (
ftnlen)128, (ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'c') {
comnotes_1.nobar1 = TRUE_;
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'r') {
/* "rename" can be set on or off. */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
comnvi_1.rename = *(unsigned char *)durq == '+';
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
goto L31;
} else if (*(unsigned char *)durq == 'n') {
/* Change # of voices. Input ninow, iiorig(1...ninow). Will use names, */
/* staves per inst. and clefs corr. to iiorig in original list of instruments. */
nvold = all_1.nv;
all_1.nv = 0;
comnvi_1.rename = TRUE_;
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ':') {
all_1.iccount += 2;
i__1 = all_1.iccount - 2;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = all_1.iccount - i__1;
ici__1.iciunit = lineq + i__1;
ici__1.icifmt = "(i2)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&comnotes_1.ninow, (ftnlen)sizeof(
integer));
e_rsfi();
} else {
comnotes_1.ninow = *(unsigned char *)durq - 48;
}
iiv = 0;
i__1 = comnotes_1.ninow;
for (iinow = 1; iinow <= i__1; ++iinow) {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (
ftnlen)1);
if (*(unsigned char *)durq == ':') {
all_1.iccount += 2;
i__2 = all_1.iccount - 2;
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = all_1.iccount - i__2;
ici__1.iciunit = lineq + i__2;
ici__1.icifmt = "(i2)";
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&comnvi_1.iiorig[iinow - 1], (
ftnlen)sizeof(integer));
e_rsfi();
} else {
comnvi_1.iiorig[iinow - 1] = *(unsigned char *)durq -
48;
}
comnvi_1.nspern[iinow - 1] = comnvi_1.nsperi[
comnvi_1.iiorig[iinow - 1] - 1];
all_1.nv += comnvi_1.nspern[iinow - 1];
*(unsigned char *)&all_1.sepsymq[iiv + comnvi_1.nspern[
iinow - 1] - 1] = '&';
if (comnvi_1.nspern[iinow - 1] > 1) {
i__2 = comnvi_1.nspern[iinow - 1] - 1;
for (iis = 1; iis <= i__2; ++iis) {
*(unsigned char *)&all_1.sepsymq[iiv + iis - 1] =
'|';
/* L64: */
}
}
iiv += comnvi_1.nspern[iinow - 1];
/* L63: */
}
/* 120818 Per Rainer's suggestion, defer changing \nbinstruments until issuing \newmovement */
/* if (islast) then */
/* if (ninow .lt. 10) then */
/* write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%' */
/* else */
/* write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%' */
/* end if */
/* end if */
if (all_1.nv == 1 && nvold > 1) {
if (comlast_1.islast) {
s_wsfe(&io___764);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 11, a__1[1] = "nostartrule";
s_cat(ch__2, a__1, i__4, &c__2, (ftnlen)12);
do_fio(&c__1, ch__2, (ftnlen)12);
e_wsfe();
}
} else if (all_1.nv > 1 && nvold == 1) {
if (comlast_1.islast) {
s_wsfe(&io___765);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 9, a__1[1] = "startrule";
s_cat(ch__3, a__1, i__4, &c__2, (ftnlen)10);
do_fio(&c__1, ch__3, (ftnlen)10);
e_wsfe();
}
}
iiv = 0;
i__1 = comnotes_1.ninow;
for (iinow = 1; iinow <= i__1; ++iinow) {
i__2 = comnvi_1.nspern[iinow - 1];
for (iis = 1; iis <= i__2; ++iis) {
++iiv;
/* May not really need to re-enter clefs, but it's easier to program since */
/* clef names are not saved but are needed in newvoice to set ncmidcc. */
getchar_(lineq, &all_1.iccount, comclefq_1.clefq + (
iiv - 1), (ftnlen)128, (ftnlen)1);
newvoice_(&iiv, comclefq_1.clefq + (iiv - 1), &c_true,
(ftnlen)1);
if (comnvi_1.nspern[iinow - 1] == 1) {
i__3 = numclef_(comclefq_1.clefq + (iiv - 1), (
ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__3);
s_copy(hdlndq, ch__1, (ftnlen)59, (ftnlen)1);
lclf = 1;
} else if (iis == 1) {
/* Writing concatenation */
i__4[0] = 1, a__1[0] = "{";
i__3 = numclef_(comclefq_1.clefq + (iiv - 1), (
ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__3);
i__4[1] = 1, a__1[1] = ch__1;
s_cat(hdlndq, a__1, i__4, &c__2, (ftnlen)59);
lclf = 2;
} else if (iis < comnvi_1.nspern[iinow - 1]) {
/* Writing concatenation */
i__4[0] = lclf, a__1[0] = hdlndq;
i__3 = numclef_(comclefq_1.clefq + (iiv - 1), (
ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__3);
i__4[1] = 1, a__1[1] = ch__1;
s_cat(hdlndq, a__1, i__4, &c__2, (ftnlen)59);
++lclf;
} else {
/* Writing concatenation */
i__5[0] = lclf, a__2[0] = hdlndq;
i__3 = numclef_(comclefq_1.clefq + (iiv - 1), (
ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__3);
i__5[1] = 1, a__2[1] = ch__1;
i__5[2] = 1, a__2[2] = "}";
s_cat(hdlndq, a__2, i__5, &c__3, (ftnlen)59);
lclf += 2;
}
/* L61: */
}
/* setstaffs & setclef go by instrument, not voice */
if (comlast_1.islast) {
if (iinow < 10) {
s_wsfe(&io___768);
/* Writing concatenation */
i__6[0] = 1, a__3[0] = all_1.sq;
i__6[1] = 9, a__3[1] = "setstaffs";
i__2 = iinow + 48;
chax_(ch__1, (ftnlen)1, &i__2);
i__6[2] = 1, a__3[2] = ch__1;
i__3 = comnvi_1.nspern[iinow - 1] + 48;
chax_(ch__5, (ftnlen)1, &i__3);
i__6[3] = 1, a__3[3] = ch__5;
i__6[4] = 1, a__3[4] = "%";
s_cat(ch__4, a__3, i__6, &c__5, (ftnlen)13);
do_fio(&c__1, ch__4, (ftnlen)13);
e_wsfe();
s_wsfe(&io___769);
/* Writing concatenation */
i__6[0] = 1, a__3[0] = all_1.sq;
i__6[1] = 7, a__3[1] = "setclef";
i__2 = iinow + 48;
chax_(ch__1, (ftnlen)1, &i__2);
i__6[2] = 1, a__3[2] = ch__1;
i__6[3] = lclf, a__3[3] = hdlndq;
i__6[4] = 1, a__3[4] = "%";
s_cat(ch__6, a__3, i__6, &c__5, (ftnlen)69);
do_fio(&c__1, ch__6, lclf + 10);
e_wsfe();
} else {
s_wsfe(&io___770);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 10, a__1[1] = "setstaffs{";
s_cat(ch__7, a__1, i__4, &c__2, (ftnlen)11);
do_fio(&c__1, ch__7, (ftnlen)11);
do_fio(&c__1, (char *)&iinow, (ftnlen)sizeof(
integer));
/* Writing concatenation */
i__5[0] = 1, a__2[0] = "}";
i__2 = comnvi_1.nspern[iinow - 1] + 48;
chax_(ch__1, (ftnlen)1, &i__2);
i__5[1] = 1, a__2[1] = ch__1;
i__5[2] = 1, a__2[2] = "%";
s_cat(ch__8, a__2, i__5, &c__3, (ftnlen)3);
do_fio(&c__1, ch__8, (ftnlen)3);
e_wsfe();
s_wsfe(&io___771);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 8, a__1[1] = "setclef{";
s_cat(ch__9, a__1, i__4, &c__2, (ftnlen)9);
do_fio(&c__1, ch__9, (ftnlen)9);
do_fio(&c__1, (char *)&iinow, (ftnlen)sizeof(
integer));
/* Writing concatenation */
i__5[0] = 1, a__2[0] = "}";
i__5[1] = lclf, a__2[1] = hdlndq;
i__5[2] = 1, a__2[2] = "%";
s_cat(ch__10, a__2, i__5, &c__3, (ftnlen)61);
do_fio(&c__1, ch__10, lclf + 2);
e_wsfe();
}
}
/* L60: */
}
/* Loop back up, this may not be last option in M. Note flow out if durq=' ' */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
goto L31;
}
/* Write instrument names */
if (! comnvi_1.rename) {
i__1 = comnotes_1.ninow;
for (iinst = 1; iinst <= i__1; ++iinst) {
if (comlast_1.islast) {
if (iinst < 10) {
s_wsfe(&io___773);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 7, a__1[1] = "setname";
s_cat(ch__11, a__1, i__4, &c__2, (ftnlen)8);
do_fio(&c__1, ch__11, (ftnlen)8);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(
integer));
do_fio(&c__1, "{}%", (ftnlen)3);
e_wsfe();
} else {
s_wsfe(&io___774);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 8, a__1[1] = "setname{";
s_cat(ch__9, a__1, i__4, &c__2, (ftnlen)9);
do_fio(&c__1, ch__9, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(
integer));
do_fio(&c__1, "}{}%", (ftnlen)4);
e_wsfe();
}
}
/* L62: */
}
} else {
i__1 = comnotes_1.ninow;
for (iinst = 1; iinst <= i__1; ++iinst) {
if (comlast_1.islast) {
if (iinst < 10) {
s_wsfe(&io___775);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 7, a__1[1] = "setname";
s_cat(ch__11, a__1, i__4, &c__2, (ftnlen)8);
do_fio(&c__1, ch__11, (ftnlen)8);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(
integer));
/* Writing concatenation */
i__5[0] = 1, a__2[0] = "{";
i__5[1] = comtop_1.lnam[comnvi_1.iiorig[iinst - 1]
- 1], a__2[1] = comtop_1.inameq + (
comnvi_1.iiorig[iinst - 1] - 1) * 79;
i__5[2] = 2, a__2[2] = "}%";
s_cat(ch__12, a__2, i__5, &c__3, (ftnlen)82);
do_fio(&c__1, ch__12, comtop_1.lnam[
comnvi_1.iiorig[iinst - 1] - 1] + 3);
e_wsfe();
} else {
s_wsfe(&io___776);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 8, a__1[1] = "setname{";
s_cat(ch__9, a__1, i__4, &c__2, (ftnlen)9);
do_fio(&c__1, ch__9, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(
integer));
/* Writing concatenation */
i__5[0] = 2, a__2[0] = "}{";
i__5[1] = comtop_1.lnam[comnvi_1.iiorig[iinst - 1]
- 1], a__2[1] = comtop_1.inameq + (
comnvi_1.iiorig[iinst - 1] - 1) * 79;
i__5[2] = 2, a__2[2] = "}%";
s_cat(ch__13, a__2, i__5, &c__3, (ftnlen)83);
do_fio(&c__1, ch__13, comtop_1.lnam[
comnvi_1.iiorig[iinst - 1] - 1] + 4);
e_wsfe();
}
}
/* L65: */
}
comnvi_1.rename = FALSE_;
}
}
} else if (*(unsigned char *)charq == '|') {
/* End of bar symbol. Check about end of bar hardspace. */
if (bit_test(all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1]
+ 1) * 24 - 1],26)) {
/* There was a hardspace followed by a bar line. Remove it from the hardspace */
/* list, store with shifts instead, set special bit. Need to repeat this code */
/* at '/'. */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],18);
++comudsp_1.nudoff[commvl_1.ivx - 1];
comudsp_1.udoff[commvl_1.ivx + comudsp_1.nudoff[commvl_1.ivx - 1]
* 24 - 25] = comudsp_1.udsp[comudsp_1.nudsp - 1];
--comudsp_1.nudsp;
all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 1] = bit_clear(all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 1],26);
}
} else if (i_indx("wS", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Width symbol or new nsyst. Read past (until blank) */
L4:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
goto L4;
}
} else if (*(unsigned char *)charq == 'l') {
/* Lower string. Only OK if at start of block */
/* Check whether at beginning of a block */
if (all_1.iv != 1 || all_1.nnl[0] != 0) {
s_wsle(&io___777);
do_lio(&c__9, &c__1, "You entered \"l\" not at beginning of block"
, (ftnlen)41);
e_wsle();
stop1_();
}
/* Set flag for lower string & read it in */
comhead_1.lower = TRUE_;
getbuf_(comhead_1.lowerq, (ftnlen)80);
all_1.iccount = 128;
} else if (*(unsigned char *)charq == 'm') {
/* Meter change. Only allow at beginning of block. */
/* mtrnuml, mtrdenl (logical) and p (printable) will be input. */
/* mtrnuml=0 initially. (In common) */
/* Check whether at beginning of a block */
if (all_1.iv != 1 || all_1.nnl[0] != 0) {
s_wsle(&io___778);
do_lio(&c__9, &c__1, "You entered \"m\" not at beginning of block"
, (ftnlen)41);
e_wsle();
stop1_();
}
readmeter_(lineq, &all_1.iccount, &all_1.mtrnuml, &all_1.mtrdenl, (
ftnlen)128);
readmeter_(lineq, &all_1.iccount, &all_1.mtrnmp, &all_1.mtrdnp, (
ftnlen)128);
lenbeat = ifnodur_(&all_1.mtrdenl, "x", (ftnlen)1);
if (all_1.mtrdenl == 2) {
lenbeat = 16;
}
all_1.lenbar = all_1.mtrnuml * lenbeat;
if (all_1.mtrdenl == 2) {
all_1.lenbar <<= 1;
}
all_1.lenb1 = all_1.lenbar;
all_1.lenb0 = 0;
if (commidi_1.ismidi) {
midievent_("m", &all_1.mtrnuml, &all_1.mtrdenl, (ftnlen)1);
}
} else if (*(unsigned char *)charq == 'C') {
/* Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. */
if (all_1.nnl[all_1.iv - 1] > 0) {
++comcc_1.ncc[all_1.iv - 1];
}
comcc_1.tcc[all_1.iv + comcc_1.ncc[all_1.iv - 1] * 24 - 25] = (real)
all_1.itsofar[all_1.iv - 1];
isl = bit_set(all_1.islur[all_1.iv + (all_1.nnl[all_1.iv - 1] + 1) *
24 - 25],11);
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* Store clef number, or 7 if clef number = 9 (French violin clef) */
/* Computing MIN */
i__1 = numclef_(durq, (ftnlen)1);
isl |= min(i__1,7) << 12;
comcc_1.ncmidcc[all_1.iv + comcc_1.ncc[all_1.iv - 1] * 24 - 25] =
ncmidf_(durq, (ftnlen)1);
/* Set marker on note with lowest voice # starting at same time. */
if (all_1.iv == 1) {
isl = bit_set(isl,15);
} else {
i__1 = all_1.iv;
for (iiv = 1; iiv <= i__1; ++iiv) {
nnliiv = all_1.nnl[iiv - 1];
if (iiv == all_1.iv) {
++nnliiv;
}
itother = 0;
i__2 = nnliiv;
for (iip = 1; iip <= i__2; ++iip) {
if (itother < all_1.itsofar[all_1.iv - 1]) {
itother += all_1.nodur[iiv + iip * 24 - 25];
goto L14;
} else if (itother == all_1.itsofar[all_1.iv - 1]) {
all_1.islur[iiv + iip * 24 - 25] = bit_set(
all_1.islur[iiv + iip * 24 - 25],15);
goto L15;
}
L14:
;
}
/* L13: */
}
L15:
;
}
/* Need 'or' since may have set bit 15 in the above loop */
all_1.islur[all_1.iv + (all_1.nnl[all_1.iv - 1] + 1) * 24 - 25] = isl
| all_1.islur[all_1.iv + (all_1.nnl[all_1.iv - 1] + 1) * 24 -
25];
} else if (*(unsigned char *)charq == 'R') {
/* Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) */
L10:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* Save designator in case it's a terminal Rr or Rd */
if (*(unsigned char *)durq == 'l') {
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24] = bit_set(all_1.islur[(
all_1.nnl[0] + 1) * 24 - 24],5);
goto L10;
} else if (i_indx("rdDbz", durq, (ftnlen)5, (ftnlen)1) > 0) {
if (*(unsigned char *)durq == 'r') {
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24] = bit_set(
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24],6);
} else if (*(unsigned char *)durq == 'd') {
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24] = bit_set(
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24],8);
} else if (*(unsigned char *)durq == 'D') {
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24] = bit_set(
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24],26);
} else if (*(unsigned char *)durq == 'b') {
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24] = bit_set(
all_1.islur[(all_1.nnl[0] + 1) * 24 - 24],25);
} else if (*(unsigned char *)durq == 'z') {
all_1.iornq[(all_1.nnl[0] + 1) * 24] = bit_set(all_1.iornq[(
all_1.nnl[0] + 1) * 24],29);
}
comget_1.rptprev = TRUE_;
*(unsigned char *)comget_1.rptfq1 = *(unsigned char *)durq;
goto L10;
}
} else if (*(unsigned char *)charq == 'V') {
/* Ending */
nnnl = all_1.nnl[0] + 1;
lvoltxt = 0;
L11:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'b' || *(unsigned char *)durq == 'x') {
/* End Volta, set bit9, and bit10 on if 'b' (end w/ box) */
all_1.islur[nnnl * 24 - 24] = bit_set(all_1.islur[nnnl * 24 - 24],
9);
if (*(unsigned char *)durq == 'b') {
all_1.islur[nnnl * 24 - 24] = bit_set(all_1.islur[nnnl * 24 -
24],10);
}
goto L11;
} else if (*(unsigned char *)durq != ' ') {
/* Start volta; Get text */
if (lvoltxt == 0) {
/* First character for text */
lvoltxt = 1;
all_1.islur[nnnl * 24 - 24] = bit_set(all_1.islur[nnnl * 24 -
24],7);
++comgrace_1.nvolt;
s_copy(comgrace_1.voltxtq + (comgrace_1.nvolt - 1) * 20, durq,
(ftnlen)20, (ftnlen)1);
} else {
/* Writing concatenation */
i__4[0] = lvoltxt, a__1[0] = comgrace_1.voltxtq + (
comgrace_1.nvolt - 1) * 20;
i__4[1] = 1, a__1[1] = durq;
s_cat(comgrace_1.voltxtq + (comgrace_1.nvolt - 1) * 20, a__1,
i__4, &c__2, (ftnlen)20);
++lvoltxt;
}
goto L11;
}
} else if (*(unsigned char *)charq == 'B') {
combc_1.bcspec = ! combc_1.bcspec;
} else if (*(unsigned char *)charq == 'P') {
/* Page numbers. Print stuff right now. */
npg1 = 0;
/* Will use ltopnam to signal whether there's a centered heading */
ltopnam = 0;
ipg1r = 0;
L16:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq >= 48 && *(unsigned char *)durq <= 57) {
npg1 = npg1 * 10 + *(unsigned char *)durq - 48;
goto L16;
} else if (*(unsigned char *)durq == 'l') {
if (npg1 == 0 || npg1 % 2 == 1) {
ipg1r = 1;
}
goto L16;
} else if (*(unsigned char *)durq == 'r') {
if (npg1 > 0 && npg1 % 2 == 0) {
ipg1r = 1;
}
goto L16;
} else if (*(unsigned char *)durq == 'c') {
/* Top-centered name. Assume this is last option. Read the name. */
/* May surround name in double quotes (to allow blanks). */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == ' ') {
ltopnam = lenstr_(comtrans_1.cheadq, &c__60, (ftnlen)60);
} else {
namstrt = all_1.iccount;
if (*(unsigned char *)durq == '"') {
/* Using quote delimiters. */
quoted = TRUE_;
++namstrt;
} else {
quoted = FALSE_;
}
for (all_1.iccount = namstrt + 1; all_1.iccount <= 128;
++all_1.iccount) {
if (quoted && *(unsigned char *)&lineq[all_1.iccount - 1]
== '"' || ! quoted && *(unsigned char *)&lineq[
all_1.iccount - 1] == ' ') {
goto L36;
}
/* On exit, iccount is OK, and name is in (namstrt:iccount-1) */
/* L35: */
}
s_wsle(&io___791);
do_lio(&c__9, &c__1, "Awww, cmon, should not be here.", (
ftnlen)31);
e_wsle();
stop1_();
L36:
ltopnam = all_1.iccount - namstrt;
s_copy(comtrans_1.cheadq, lineq + (namstrt - 1), (ftnlen)60,
all_1.iccount - 1 - (namstrt - 1));
}
}
/* Done getting data, now assemble the command */
if (npg1 == 0) {
npg1 = 1;
}
/* 2/23/03 Don't use \atnextline if on first page and only one system */
/* if (ipage.gt.1 .or. nsystp(1).gt.1) then */
/* Writing concatenation */
i__7[0] = 1, a__4[0] = all_1.sq;
i__7[1] = 3, a__4[1] = "def";
i__7[2] = 1, a__4[2] = all_1.sq;
i__7[3] = 11, a__4[3] = "atnextline{";
i__7[4] = 1, a__4[4] = all_1.sq;
i__7[5] = 10, a__4[5] = "toppageno{";
s_cat(hdlndq, a__4, i__7, &c__6, (ftnlen)59);
lhead = 27;
/* else */
/* hdlndq = sq//'toppageno{' */
/* lhead = 11 */
/* end if */
if (npg1 < 10) {
/* Note we are overwriting the last "{" */
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = hdlndq + (lhead - 1);
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&npg1, (ftnlen)sizeof(integer));
e_wsfi();
} else if (npg1 < 100) {
lhead += 3;
i__1 = lhead - 3;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lhead - i__1;
ici__1.iciunit = hdlndq + i__1;
ici__1.icifmt = "(i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&npg1, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
} else {
lhead += 4;
i__1 = lhead - 4;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lhead - i__1;
ici__1.iciunit = hdlndq + i__1;
ici__1.icifmt = "(i3,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&npg1, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
}
/* Writing concatenation */
i__5[0] = lhead, a__2[0] = hdlndq;
i__1 = ipg1r + 48;
chax_(ch__1, (ftnlen)1, &i__1);
i__5[1] = 1, a__2[1] = ch__1;
i__5[2] = 1, a__2[2] = "{";
s_cat(hdlndq, a__2, i__5, &c__3, (ftnlen)59);
lhead += 2;
/* if (ipage.gt.1 .or. nsystp(1).gt.1) then */
if (ltopnam == 0) {
if (comlast_1.islast) {
s_wsfe(&io___793);
/* Writing concatenation */
i__4[0] = lhead, a__1[0] = hdlndq;
i__4[1] = 3, a__1[1] = "}}%";
s_cat(ch__14, a__1, i__4, &c__2, (ftnlen)62);
do_fio(&c__1, ch__14, lhead + 3);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___794);
/* Writing concatenation */
i__5[0] = lhead, a__2[0] = hdlndq;
i__5[1] = ltopnam, a__2[1] = comtrans_1.cheadq;
i__5[2] = 3, a__2[2] = "}}%";
s_cat(ch__15, a__2, i__5, &c__3, (ftnlen)122);
do_fio(&c__1, ch__15, lhead + ltopnam + 3);
e_wsfe();
}
}
/* else */
/* if (ltopnam .eq. 0) then */
/* if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' */
/* else */
/* if (islast) */
/* * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' */
/* end if */
/* end if */
} else if (*(unsigned char *)charq == 'W') {
/* Just eat the number that must follow, it was used in pmxa */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
} else if (*(unsigned char *)charq == 'T') {
comtitl_1.headlog = TRUE_;
comtitl_1.inhead = 0;
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'i') {
getbuf_(comtitl_1.instrq, (ftnlen)120);
/* A kluge for parts from separate score file for later movements. */
if (*(unsigned char *)comtitl_1.instrq == ' ') {
comtitl_1.headlog = FALSE_;
}
s_copy(comtrans_1.cheadq, comtitl_1.instrq, (ftnlen)60, (ftnlen)
120);
} else if (*(unsigned char *)durq == 't') {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* Optionally can include extra vertical \internotes above inbothd */
if (i_indx("-+0123456789", durq, (ftnlen)12, (ftnlen)1) > 0) {
ipm = 1;
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Don't trust readnum to round this negative integer properly */
++all_1.iccount;
if (*(unsigned char *)durq == '-') {
ipm = -1;
}
}
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (
ftnlen)1);
comtitl_1.inhead = ipm * i_nint(&fnum);
}
getbuf_(comtitl_1.titleq, (ftnlen)120);
} else {
getbuf_(comtitl_1.compoq, (ftnlen)120);
}
comtitl_1.inhead += cominbot_1.inbothd;
all_1.iccount = 128;
} else if (*(unsigned char *)charq == 'A') {
/* Accidental handling etc. */
L27:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'r') {
if (comlast_1.islast) {
commidi_1.relacc = TRUE_;
s_wsfe(&io___795);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 14, a__1[1] = "relativeaccid%";
s_cat(ch__16, a__1, i__4, &c__2, (ftnlen)15);
do_fio(&c__1, ch__16, (ftnlen)15);
e_wsfe();
}
} else if (*(unsigned char *)durq == 's') {
spfacs_1.bacfac = 1e6f;
} else if (*(unsigned char *)durq == 'b') {
if (comlast_1.islast) {
s_wsfe(&io___796);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 9, a__1[1] = "bigaccid%";
s_cat(ch__3, a__1, i__4, &c__2, (ftnlen)10);
do_fio(&c__1, ch__3, (ftnlen)10);
e_wsfe();
}
spfacs_1.accfac = spfacs_1.bacfac;
} else if (*(unsigned char *)durq == 'a') {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
--all_1.iccount;
} else if (*(unsigned char *)durq == 'i') {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
readnum_(lineq, &all_1.iccount, durq, &tintstf, (ftnlen)128, (
ftnlen)1);
if (! all_1.firstgulp) {
comget_1.fintstf = tintstf;
}
/* Local corrections for first page were handled by pmxa */
--all_1.iccount;
} else if (*(unsigned char *)durq == 'I') {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
readnum_(lineq, &all_1.iccount, durq, &comget_1.gintstf, (ftnlen)
128, (ftnlen)1);
--all_1.iccount;
} else if (*(unsigned char *)durq == 'd') {
comarp_1.lowdot = TRUE_;
} else if (*(unsigned char *)durq == 'o') {
} else if (*(unsigned char *)durq == 'S') {
/* 130324 */
/* do 50 iiv = 1 , nv */
i__1 = comkeys_2.noinst;
for (iiv = 1; iiv <= i__1; ++iiv) {
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("-s", durq, (ftnlen)2, (ftnlen)1) > 0) {
comfig_1.fullsize[iiv - 1] = .8f;
} else if (*(unsigned char *)durq == 't') {
comfig_1.fullsize[iiv - 1] = .64f;
} else {
/* fullsize(ivx) = 1.0 */
comfig_1.fullsize[iiv - 1] = 1.f;
}
/* L50: */
}
} else if (*(unsigned char *)durq == 'e') {
/* Line-spacing equalization */
comget_1.equalize = TRUE_;
/* The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. */
/* But it causes problems with some older scores and when excerpts are combined */
/* with LaTeX. So as of 2.352 we write it here. */
s_wsfe(&io___798);
/* Writing concatenation */
i__8[0] = 1, a__5[0] = all_1.sq;
i__8[1] = 6, a__5[1] = "global";
i__8[2] = 1, a__5[2] = all_1.sq;
i__8[3] = 19, a__5[3] = "parskip 0pt plus 12";
i__8[4] = 1, a__5[4] = all_1.sq;
i__8[5] = 19, a__5[5] = "Interligne minus 99";
i__8[6] = 1, a__5[6] = all_1.sq;
i__8[7] = 11, a__5[7] = "Interligne%";
s_cat(ch__17, a__5, i__8, &c__8, (ftnlen)59);
do_fio(&c__1, ch__17, (ftnlen)59);
e_wsfe();
s_copy(tempq, all_1.sepsymq, (ftnlen)24, (ftnlen)1);
lentemp = 1;
i__1 = all_1.nv - 1;
for (iiv = 2; iiv <= i__1; ++iiv) {
/* Writing concatenation */
i__4[0] = lentemp, a__1[0] = tempq;
i__4[1] = 1, a__1[1] = all_1.sepsymq + (iiv - 1);
s_cat(tempq, a__1, i__4, &c__2, (ftnlen)24);
++lentemp;
/* L51: */
}
s_wsfe(&io___801);
/* Writing concatenation */
i__9[0] = 1, a__6[0] = all_1.sq;
i__9[1] = 3, a__6[1] = "def";
i__9[2] = 1, a__6[2] = all_1.sq;
i__9[3] = 8, a__6[3] = "upstrut{";
i__9[4] = 1, a__6[4] = all_1.sq;
i__9[5] = 6, a__6[5] = "znotes";
i__9[6] = lentemp, a__6[6] = tempq;
i__9[7] = 1, a__6[7] = all_1.sq;
i__9[8] = 10, a__6[8] = "zcharnote{";
i__9[9] = 1, a__6[9] = all_1.sq;
i__9[10] = 9, a__6[10] = "upamt}{~}";
i__9[11] = 1, a__6[11] = all_1.sq;
i__9[12] = 4, a__6[12] = "en}%";
s_cat(ch__18, a__6, i__9, &c__13, (ftnlen)70);
do_fio(&c__1, ch__18, lentemp + 46);
e_wsfe();
} else if (*(unsigned char *)durq == 'v') {
/* Toggle usevshrink */
comlast_1.usevshrink = ! comlast_1.usevshrink;
} else if (*(unsigned char *)durq == 'p') {
/* Postscript slurs. fontslur is already false (set in g1etnote) */
if (! comslur_1.wrotepsslurdefaults) {
/* Set postscrirpt slur adjustment defaults */
s_wsfe(&io___802);
/* Writing concatenation */
i__7[0] = 1, a__4[0] = all_1.sq;
i__7[1] = 12, a__4[1] = "Nosluradjust";
i__7[2] = 1, a__4[2] = all_1.sq;
i__7[3] = 11, a__4[3] = "Notieadjust";
i__7[4] = 1, a__4[4] = all_1.sq;
i__7[5] = 10, a__4[5] = "nohalfties";
s_cat(ch__19, a__4, i__7, &c__6, (ftnlen)36);
do_fio(&c__1, ch__19, (ftnlen)36);
e_wsfe();
comslur_1.wrotepsslurdefaults = TRUE_;
}
L52:
g1etchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* might be "+", "-", "h" or */
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Characters to change defaults for ps slurs */
g1etchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)
1);
/* charq will be "s,t,h,c */
if (*(unsigned char *)durq == '+') {
if (*(unsigned char *)charq == 's') {
s_wsfe(&io___803);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 10, a__1[1] = "Sluradjust";
s_cat(ch__7, a__1, i__4, &c__2, (ftnlen)11);
do_fio(&c__1, ch__7, (ftnlen)11);
e_wsfe();
} else if (*(unsigned char *)charq == 't') {
s_wsfe(&io___804);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 9, a__1[1] = "Tieadjust";
s_cat(ch__3, a__1, i__4, &c__2, (ftnlen)10);
do_fio(&c__1, ch__3, (ftnlen)10);
e_wsfe();
} else if (*(unsigned char *)charq == 'h') {
s_wsfe(&io___805);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 8, a__1[1] = "halfties";
s_cat(ch__9, a__1, i__4, &c__2, (ftnlen)9);
do_fio(&c__1, ch__9, (ftnlen)9);
e_wsfe();
} else {
comslur_1.slurcurve += 1;
if (comslur_1.slurcurve > 3.1f) {
printl_("WARNING!", (ftnlen)8);
printl_("Default slur curvature advanced past HH"
", resetting", (ftnlen)50);
comslur_1.slurcurve = 3.f;
}
}
} else {
if (*(unsigned char *)charq == 's') {
s_wsfe(&io___806);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 12, a__1[1] = "Nosluradjust";
s_cat(ch__4, a__1, i__4, &c__2, (ftnlen)13);
do_fio(&c__1, ch__4, (ftnlen)13);
e_wsfe();
} else if (*(unsigned char *)charq == 't') {
s_wsfe(&io___807);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 11, a__1[1] = "Notieadjust";
s_cat(ch__2, a__1, i__4, &c__2, (ftnlen)12);
do_fio(&c__1, ch__2, (ftnlen)12);
e_wsfe();
} else if (*(unsigned char *)charq == 'h') {
s_wsfe(&io___808);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = all_1.sq;
i__4[1] = 10, a__1[1] = "nohalfties";
s_cat(ch__7, a__1, i__4, &c__2, (ftnlen)11);
do_fio(&c__1, ch__7, (ftnlen)11);
e_wsfe();
} else {
comslur_1.slurcurve += -1;
if (comslur_1.slurcurve < -1.1f) {
printl_("WARNING!", (ftnlen)8);
printl_("Default slur curvature decremented belo"
"w f, resetting", (ftnlen)53);
comslur_1.slurcurve = -1.f;
}
}
}
goto L52;
/* Check for another set of default changes */
} else if (*(unsigned char *)durq == 'l') {
/* Set optional linebreak ties */
comnotes_1.optlinebreakties = TRUE_;
goto L52;
} else if (*(unsigned char *)durq == 'h') {
/* Set flag to write header special on every page */
comnotes_1.headerspecial = TRUE_;
goto L52;
} else {
--all_1.iccount;
}
} else if (*(unsigned char *)durq == 'K') {
/* Toggle keyboard rest placement flag */
comkbdrests_1.kbdrests = ! comkbdrests_1.kbdrests;
} else if (*(unsigned char *)durq == 'c') {
g1etchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* Just eat the input; it was used in pmax */
goto L27;
}
if (i_indx("NR", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Override default part names for scor2prt, or normal include file. */
/* Just bypass rest of input line */
all_1.iccount = 128;
} else if (*(unsigned char *)durq != ' ') {
goto L27;
}
} else if (*(unsigned char *)charq == 'K') {
L77:
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'n') {
comignorenats_1.ignorenats = TRUE_;
goto L77;
}
if (*(unsigned char *)durq != 'i') {
/* Normal, full-score key change and/or transposition */
num1 = 44 - *(unsigned char *)durq;
++all_1.iccount;
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
num1 *= i_nint(&fnum);
/* On exit, durq='+','-'. But only need isig if after start, else done in pmxa */
++all_1.iccount;
readnum_(lineq, &all_1.iccount, charq, &fnum, (ftnlen)128, (
ftnlen)1);
if (commidi_1.ismidi) {
commidisig_1.midisig = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
commidisig_1.midisig = -commidisig_1.midisig;
}
/* 130317 */
commidisig_1.midisig += comtop_1.idsig;
midievent_("k", &commidisig_1.midisig, &c__0, (ftnlen)1);
}
/* 70 continue */
if (num1 == 0) {
/* Key change, not transposition. */
all_1.ipl[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) *
24 - 25] = bit_set(all_1.ipl[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] + 1) * 24 - 25],28);
comtop_1.lastisig = comtop_1.isig;
comtop_1.isig = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
comtop_1.isig = -comtop_1.isig;
}
comtop_1.isig += comtop_1.idsig;
if (commidi_1.ismidi) {
midievent_("k", &comtop_1.isig, &c__0, (ftnlen)1);
}
} else {
/* num1 .ne. 0, so transposition, so must be at beginning. isig came with K... */
/* but was passed to pmxb through pmxtex.dat. isig0 comes from setup data */
/* (signature before transposition). idsig must be added to future key changes. */
jv = 0;
while(jv < 24) {
++jv;
cominsttrans_1.itransamt[jv - 1] = num1;
}
comtop_1.idsig = comtop_1.isig - comtop_1.isig0;
}
} else {
/* Instrument specific transposition. */
getitransinfo_(&c_false, &combibarcnt_1.ibarcnt, lineq, &
all_1.iccount, &ibaroff, &all_1.nbars, &comkeys_2.noinst,
&all_1.iv, (ftnlen)128);
/* The sig parameters will have been set 1st time but that's OK */
}
} else if (*(unsigned char *)charq == '/') {
if (bit_test(all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1]
+ 1) * 24 - 1],26)) {
/* There was a hardspace followed by end of block. Remove it from the hardspace */
/* list, store with shifts instead, set special bit. This code also at '|' */
all_1.irest[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= bit_set(all_1.irest[commvl_1.ivx + all_1.nnl[
commvl_1.ivx - 1] * 24 - 25],18);
++comudsp_1.nudoff[commvl_1.ivx - 1];
comudsp_1.udoff[commvl_1.ivx + comudsp_1.nudoff[commvl_1.ivx - 1]
* 24 - 25] = comudsp_1.udsp[comudsp_1.nudsp - 1];
--comudsp_1.nudsp;
all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) * 24
- 1] = bit_clear(all_1.iornq[commvl_1.ivx + (all_1.nnl[
commvl_1.ivx - 1] + 1) * 24 - 1],26);
}
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
/* Save ending note level: */
if (commvl_1.ivx <= all_1.nv) {
/* This is the first line of music on this staff. If previous block had only 1 */
/* voice, save last pitch from line 1 of prev. block to line 2, in case a */
/* 2nd line is started just below */
if (! comnotes_1.was2[all_1.iv - 1]) {
comnotes_1.ndlev[all_1.iv + 23] = comnotes_1.ndlev[all_1.iv -
1];
}
comnotes_1.was2[all_1.iv - 1] = FALSE_;
comnotes_1.ndlev[all_1.iv - 1] = comnotes_1.lastlev;
} else {
/* This is the 2nd line of music on this staff. */
comnotes_1.was2[all_1.iv - 1] = TRUE_;
comnotes_1.ndlev[all_1.iv + 23] = comnotes_1.lastlev;
}
if (*(unsigned char *)durq == ' ' && all_1.iv == all_1.nv) {
/* End of input block */
*loop = FALSE_;
} else {
/* Start a new line of music */
if (all_1.lenb0 != 0 && all_1.firstgulp) {
all_1.lenbar = all_1.lenb0;
}
all_1.nbars = 0;
if (*(unsigned char *)durq == ' ') {
/* New line of music is on next staff */
++all_1.iv;
commvl_1.ivx = all_1.iv;
} else {
/* durq must be 2nd '/'. New line of music is on same staff. Set up for it */
commvl_1.ivx = all_1.nv + 1;
i__1 = all_1.nv;
for (iiv = 1; iiv <= i__1; ++iiv) {
if (commvl_1.nvmx[iiv - 1] == 2) {
++commvl_1.ivx;
}
/* L23: */
}
commvl_1.nvmx[all_1.iv - 1] = 2;
commvl_1.ivmx[all_1.iv + 23] = commvl_1.ivx;
all_1.itsofar[commvl_1.ivx - 1] = 0;
all_1.nnl[commvl_1.ivx - 1] = 0;
comfb_1.nfb[commvl_1.ivx - 1] = 0;
comudsp_1.nudoff[commvl_1.ivx - 1] = 0;
comcc_1.ndotmv[commvl_1.ivx - 1] = 0;
for (j = 1; j <= 200; ++j) {
all_1.irest[commvl_1.ivx + j * 24 - 25] = 0;
all_1.islur[commvl_1.ivx + j * 24 - 25] = 0;
all_1.nacc[commvl_1.ivx + j * 24 - 25] = 0;
all_1.iornq[commvl_1.ivx + j * 24 - 1] = 0;
all_1.ipl[commvl_1.ivx + j * 24 - 25] = 0;
all_1.mult[commvl_1.ivx + j * 24 - 25] = 0;
/* L24: */
}
/* Go back and lower the rests in voice "a" that don't have over-ridden heights */
i__1 = all_1.nnl[all_1.iv - 1];
for (j = 1; j <= i__1; ++j) {
if (bit_test(all_1.irest[all_1.iv + j * 24 - 25],0) &&
all_1.nolev[all_1.iv + j * 24 - 25] == 0) {
all_1.nolev[all_1.iv + j * 24 - 25] = -4;
}
/* L26: */
}
}
}
all_1.iccount = 128;
} else if (*(unsigned char *)charq == 'X') {
/* 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, */
/* which only happens for normal X at block start, and we took special measures to */
/* keep group shifts for crossing block boundaries. */
/* Computing MAX */
i__1 = 1, i__2 = all_1.nnl[commvl_1.ivx - 1];
getx_(lineq, &all_1.iccount, &all_1.irest[commvl_1.ivx + max(i__1,
i__2) * 24 - 25], &comnotes_1.shifton, &comask_1.wheadpt, &
all_1.iornq[commvl_1.ivx + (all_1.nnl[commvl_1.ivx - 1] + 1) *
24 - 1], &commvl_1.ivx, &all_1.irest[commvl_1.ivx + (
all_1.nnl[commvl_1.ivx - 1] + 1) * 24 - 25], &all_1.itsofar[
commvl_1.ivx - 1], &c__0, &c__0, &c__0, " ", &ndoub, (ftnlen)
128, (ftnlen)1);
} else if (*(unsigned char *)charq == 'I') {
/* Midi controls. */
/* call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, */
getmidi_(&comkeys_2.noinst, lineq, &all_1.iccount, &
combibarcnt_1.ibarcnt, &ibaroff, &all_1.nbars, &all_1.lenbar,
&all_1.mtrdenl, &c_false, (ftnlen)128);
} else if (*(unsigned char *)charq == 'M') {
/* Macro action */
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("RS", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Record or save a macro. Get the number of the macro. */
getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1);
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
commac_1.macnum = i_nint(&fnum);
commac_1.macuse = bit_set(commac_1.macuse,commac_1.macnum);
if (*(unsigned char *)charq == 'R') {
mrec1_(lineq, &all_1.iccount, &ndxm, (ftnlen)128);
} else {
/* Save (Record but don't activate) */
L5:
mrec1_(lineq, &all_1.iccount, &ndxm, (ftnlen)128);
if (commac_1.mrecord) {
getbuf_(lineq, (ftnlen)128);
all_1.iccount = 0;
goto L5;
}
all_1.iccount = all_1.iccount + ndxm + 1;
}
} else if (*(unsigned char *)charq == 'P') {
/* Playback the macro */
getchar_(lineq, &all_1.iccount, charq, (ftnlen)128, (ftnlen)1);
readnum_(lineq, &all_1.iccount, durq, &fnum, (ftnlen)128, (ftnlen)
1);
commac_1.macnum = i_nint(&fnum);
commac_1.icchold = all_1.iccount;
s_copy(commac_1.lnholdq, lineq, (ftnlen)128, (ftnlen)128);
all_1.iccount = 128;
c1ommac_1.ilmac = c1ommac_1.il1mac[commac_1.macnum - 1];
commac_1.mplay = TRUE_;
}
} else if (i_indx(",.", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Continued rhythmic shortcut */
idotform = i_indx(". ,", charq, (ftnlen)3, (ftnlen)1);
if (idotform == 1) {
/* Check for start of forced beam on 2nd member of dotform=1 shortcut */
if (comget_1.fbon) {
if (comfb_1.t1fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1]
* 24 - 25] == (real) all_1.itsofar[commvl_1.ivx - 1])
{
comfb_1.t1fb[commvl_1.ivx + comfb_1.nfb[commvl_1.ivx - 1]
* 24 - 25] += all_1.nodur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25] / 2;
}
}
/* Change duration of prior note */
all_1.itsofar[commvl_1.ivx - 1] -= all_1.nodur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25];
all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] * 24 - 25]
= all_1.nodur[commvl_1.ivx + all_1.nnl[commvl_1.ivx - 1] *
24 - 25] * 3 / 2;
all_1.itsofar[commvl_1.ivx - 1] += all_1.nodur[commvl_1.ivx +
all_1.nnl[commvl_1.ivx - 1] * 24 - 25];
}
++idotform;
numnum = 1;
cdot = TRUE_;
goto L1;
}
return 0;
} /* getnote_ */
/* Subroutine */ int getorn_(char *lineq, integer *iccount, integer *iornq,
integer *iornq0, logical *ornrpt, integer *noffseg, integer *ip,
integer *ivx, logical *noxtup, logical *notcrd, integer *nole, ftnlen
lineq_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *), s_wsle(
cilist *), do_lio(integer *, integer *, char *, ftnlen), e_wsle(
void);
/* Local variables */
static real fnum;
static integer korn;
static char durq[1];
extern /* Subroutine */ int stop1_(void);
static char charq[1];
static integer iorni;
static logical negseg;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen);
static integer iofforn;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
static real xofforn;
/* Fortran I/O blocks */
static cilist io___820 = { 0, 6, 0, 0, 0 };
/* iornq: Main note. Do not alter if chord note, except turn on bit 23 */
/* iornq0: Store iorni + bit 23, in case of repeated ornaments */
/* iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. */
/* noffseg: horiz. offset for segno */
/* nole: level of note w/ orn, used to ID the note/orn if there's a level shift. */
/* Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U */
/* 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 ? for ed. accid. */
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (i_indx("bc", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) */
/* ivx(0-3,28), ip(4-12), */
/* vshift (vshift+32 in bits 13-18), */
/* hshift (nint(10*vshift)+128 in bits 19-26) */
/* bit 27 = 0 if caesura, 1 if breath */
/* bit 28: 5th bit of ivx */
*iornq = bit_set(*iornq,28);
++comcb_1.nbc;
/* ibcdata(nbc) = ivx+16*ip */
comcb_1.ibcdata[comcb_1.nbc - 1] = *ivx % 16 + (*ip << 4);
if (*ivx >= 16) {
comcb_1.ibcdata[comcb_1.nbc - 1] = bit_set(comcb_1.ibcdata[
comcb_1.nbc - 1],28);
}
if (*(unsigned char *)charq == 'b') {
comcb_1.ibcdata[comcb_1.nbc - 1] = bit_set(comcb_1.ibcdata[
comcb_1.nbc - 1],27);
}
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* We have a vertical shift, get it */
++(*iccount);
readnum_(lineq, iccount, charq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '-') {
fnum = -fnum;
}
r__1 = fnum + 32;
i__1 = i_nint(&r__1);
setbits_(&comcb_1.ibcdata[comcb_1.nbc - 1], &c__6, &c__13, &i__1);
if (i_indx("+-", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Horizontal shift, get it */
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == '-') {
fnum = -fnum;
}
r__1 = fnum * 10;
i__1 = i_nint(&r__1) + 128;
setbits_(&comcb_1.ibcdata[comcb_1.nbc - 1], &c__8, &c__19, &
i__1);
}
}
return 0;
}
/* Set signal on main note that some note at this time has ornament. ONLY used */
/* in beamstrt to activate further tests for whether ihornb is needed. */
*iornq = bit_set(*iornq,23);
/* Isolate 21 bits defining exisiting ornaments */
if (*notcrd) {
iorni = 4194303 & *iornq;
} else {
iorni = 4194303 & comtrill_1.icrdorn[comtrill_1.ncrd - 1];
}
korn = i_indx("stmgx+Tupf._)e:XXX>^", charq, (ftnlen)20, (ftnlen)1);
if (korn != 15) {
iorni = bit_set(iorni,korn);
}
/* Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later */
/* as follows: korn=16-18 for sfn, and or 21 for bare ?. */
/* When this if-block is done, korn will = bit# of actual ornament (unless "?"). */
if (korn == 15) {
/* c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq */
/* Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq */
/* iorni = ior(iorni,iand(iornq0,1638383)) */
iorni |= *iornq0 & 3735535;
*ornrpt = FALSE_;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* durq will be ' ' */
} else if (korn == 14) {
/* Editorial accidental */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* korn = 15+index('sfn',durq) */
korn = i_indx("sfn?", durq, (ftnlen)4, (ftnlen)1) + 15;
if (korn == 19) {
korn = 21;
}
iorni = bit_set(bit_clear(iorni,14),korn);
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '?') {
/* This is "oe[s|f|n]?". Set 21st bit also. */
iorni = bit_set(iorni,21);
korn += 6;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
}
/* iorni = ibset(ibclr(iorni,14),korn) */
} else if (korn == 4 && *noxtup) {
/* segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points */
*noffseg = 0;
negseg = FALSE_;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
/* Segno shift is specified */
if (*(unsigned char *)durq == '-') {
negseg = TRUE_;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
*noffseg = (integer) fnum;
if (negseg) {
*noffseg = -(*noffseg);
}
}
} else if (korn == 7) {
/* Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" */
++comtrill_1.ntrill;
comtrill_1.ivtrill[comtrill_1.ntrill - 1] = *ivx;
comtrill_1.iptrill[comtrill_1.ntrill - 1] = *ip;
comtrill_1.xnsktr[comtrill_1.ntrill - 1] = 1.f;
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 't') {
/* Convert to new internal symbol for non-'"tr" trill */
korn = 15;
iorni = bit_set(bit_clear(iorni,7),15);
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
}
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) > 0) {
/* We have a number for the length */
readnum_(lineq, iccount, durq, &comtrill_1.xnsktr[
comtrill_1.ntrill - 1], (ftnlen)128, (ftnlen)1);
}
} else if (korn == 10 && *noxtup) {
/* Fermata */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'd') {
korn = 14;
iorni = bit_set(bit_clear(iorni,10),14);
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
}
} else {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
}
if (i_indx("+- :", durq, (ftnlen)4, (ftnlen)1) == 0) {
s_wsle(&io___820);
do_lio(&c__9, &c__1, "Unexpected character at end of ornament: ", (
ftnlen)41);
do_lio(&c__9, &c__1, durq, (ftnlen)1);
e_wsle();
stop1_();
}
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Shift ornament up or down */
++comtrill_1.nudorn;
/* Set bit 25 in iorni as a signal. This may not really be necessary. */
iorni = bit_set(iorni,25);
/* Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, */
/* 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present */
xofforn = (real) (44 - *(unsigned char *)durq);
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
r__1 = xofforn * fnum;
iofforn = i_nint(&r__1);
comtrill_1.kudorn[comtrill_1.nudorn - 1] = *ip + (*ivx % 16 << 8) + (*
nole << 12) + (korn << 19) + (iofforn + 32 << 25);
comivxudorn_1.ivxudorn[comtrill_1.nudorn - 1] = *ivx;
if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
/* Horizontal shift */
comtrill_1.kudorn[comtrill_1.nudorn - 1] = bit_set(
comtrill_1.kudorn[comtrill_1.nudorn - 1],31);
xofforn = (real) (44 - *(unsigned char *)durq);
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
r__1 = xofforn * fnum;
comtrill_1.ornhshft[comtrill_1.nudorn - 1] = (real) i_nint(&r__1);
}
} else if (*(unsigned char *)durq == ':') {
/* Turn on repeated ornaments */
*ornrpt = TRUE_;
/* Save the ornament value just set */
*iornq0 = iorni;
}
if (*notcrd) {
*iornq |= iorni;
} else {
comtrill_1.icrdorn[comtrill_1.ncrd - 1] |= iorni;
}
return 0;
} /* getorn_ */
/* Subroutine */ int getpmxmod_(logical *global, char *includeq, ftnlen
includeq_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1[3], i__2[2], i__3;
char ch__1[114], ch__2[106], ch__3[108], ch__4[88];
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer f_inqu(inlist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer f_open(olist *), s_rsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_rsfe(void), f_clos(cllist *);
/* Local variables */
static integer ilbufmod, ipbufmod, lenbufmod, lenmodline;
static char pmxmoddirq[80];
static integer lpmxmoddirq;
extern /* Subroutine */ int stop1_(void);
static integer ilbuff;
extern /* Subroutine */ int getenv_(char *, char *, ftnlen, ftnlen);
static logical fexist;
extern integer lenstr_(char *, integer *, ftnlen);
extern /* Subroutine */ int printl_(char *, ftnlen);
static char lnholdq[128];
/* Fortran I/O blocks */
static cilist io___826 = { 0, 6, 0, 0, 0 };
static cilist io___827 = { 0, 15, 0, "()", 0 };
static cilist io___831 = { 0, 18, 1, "(a)", 0 };
/* If global=.true., checks for environment variable with path to pmx.mod. */
/* Then, if variable exists and points to pmx.mod, insert lines from */
/* pmx.mod into buffer */
/* If global=.false., checks for existence of includeq and uses it. */
/* lenbuf0 = total length of bufq on entry */
/* lbuf(i) = length of line (i) */
/* nlbuf = number of lines stored in bufq */
/* ilbuf = index of first line after setup stuff (on entry). In general, index of */
/* next line to be sucked from buffer. */
/* ilbufmod = counter for lines in pmx.mod as they are grabbed. */
/* Starts at ilbuf. Points to position of next line after */
/* pmx.mod stuff in bufq on exiting loop 1 */
/* ilbuff = transient counter for shifting operations */
/* ipbuf = on entry, points to last character in setup stuff. In general, points */
/* to last character of most recent line sucked from buffer. */
/* ipbufmod = points to last character of most recent inserted line */
/* from pmx.mod */
c1omget_1.line1pmxmod = inbuff_1.ilbuf;
if (! (*global)) {
ioin__1.inerr = 0;
ioin__1.infilen = includeq_len;
ioin__1.infile = includeq;
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);
/* Transfer includeq to temporary char variable with known length */
s_copy(pmxmoddirq, includeq, (ftnlen)80, includeq_len);
lpmxmoddirq = lenstr_(pmxmoddirq, &c__80, (ftnlen)80);
s_wsle(&io___826);
e_wsle();
s_wsfe(&io___827);
e_wsfe();
if (! fexist) {
/* Writing concatenation */
i__1[0] = 15, a__1[0] = "Could not find ";
i__1[1] = lpmxmoddirq, a__1[1] = pmxmoddirq;
i__1[2] = 19, a__1[2] = ", checking further.";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)114);
printl_(ch__1, lpmxmoddirq + 34);
/* File named includeq doesn't not exist. Get directory from PMXMODDIR and */
/* see if it's there */
getenv_("PMXMODDIR", pmxmoddirq, (ftnlen)9, (ftnlen)80);
lpmxmoddirq = lenstr_(pmxmoddirq, &c__80, (ftnlen)80);
if (lpmxmoddirq > 0) {
/* Writing concatenation */
i__2[0] = lpmxmoddirq, a__2[0] = pmxmoddirq;
i__2[1] = includeq_len, a__2[1] = includeq;
s_cat(pmxmoddirq, a__2, i__2, &c__2, (ftnlen)80);
lpmxmoddirq = lenstr_(pmxmoddirq, &c__80, (ftnlen)80);
} else {
printl_("No other directory defined by PMXMODDIR, stopping", (
ftnlen)49);
stop1_();
}
ioin__1.inerr = 0;
ioin__1.infilen = 80;
ioin__1.infile = pmxmoddirq;
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) {
/* Writing concatenation */
i__1[0] = 15, a__1[0] = "Could not find ";
i__1[1] = lpmxmoddirq, a__1[1] = pmxmoddirq;
i__1[2] = 11, a__1[2] = ", stopping.";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)106);
printl_(ch__2, lpmxmoddirq + 26);
stop1_();
}
}
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "Opening normal include file ";
i__2[1] = lpmxmoddirq, a__2[1] = pmxmoddirq;
s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)108);
printl_(ch__3, lpmxmoddirq + 28);
o__1.oerr = 0;
o__1.ounit = 18;
o__1.ofnmlen = 80;
o__1.ofnm = pmxmoddirq;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
} else {
/* Check for existence of pmx.mod */
getenv_("PMXMODDIR", pmxmoddirq, (ftnlen)9, (ftnlen)80);
lpmxmoddirq = lenstr_(pmxmoddirq, &c__80, (ftnlen)80);
if (lpmxmoddirq == 0) {
return 0;
}
/* Writing concatenation */
i__2[0] = lpmxmoddirq, a__2[0] = pmxmoddirq;
i__2[1] = 7, a__2[1] = "pmx.mod";
s_cat(pmxmoddirq, a__2, i__2, &c__2, (ftnlen)80);
lpmxmoddirq += 7;
ioin__1.inerr = 0;
ioin__1.infilen = 80;
ioin__1.infile = pmxmoddirq;
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) {
return 0;
}
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "Opening global include file ";
i__2[1] = lpmxmoddirq, a__2[1] = pmxmoddirq;
s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)108);
printl_(ch__3, lpmxmoddirq + 28);
o__1.oerr = 0;
o__1.ounit = 18;
o__1.ofnmlen = lpmxmoddirq;
o__1.ofnm = pmxmoddirq;
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
}
printl_("Adding include data", (ftnlen)19);
/* Read lines in from pmx.mod one at a time */
ipbufmod = inbuff_1.ipbuf;
lenbufmod = c1omget_1.lenbuf0;
for (ilbufmod = inbuff_1.ilbuf; ilbufmod <= 4000; ++ilbufmod) {
i__3 = s_rsfe(&io___831);
if (i__3 != 0) {
goto L3;
}
i__3 = do_fio(&c__1, lnholdq, (ftnlen)128);
if (i__3 != 0) {
goto L3;
}
i__3 = e_rsfe();
if (i__3 != 0) {
goto L3;
}
/* A line was read. Slide all existing lengths from here forward ahead by 1 */
i__3 = ilbufmod;
for (ilbuff = inbuff_1.nlbuf; ilbuff >= i__3; --ilbuff) {
inbuff_1.lbuf[ilbuff] = inbuff_1.lbuf[ilbuff - 1];
/* L2: */
}
/* Get length of line from include file */
lenmodline = lenstr_(lnholdq, &c__128, (ftnlen)128);
if (lenmodline == 0) {
/* Blank line. Make it a single blank with length 1 */
lenmodline = 1;
s_copy(lnholdq, " ", (ftnlen)128, (ftnlen)1);
}
inbuff_1.lbuf[ilbufmod - 1] = (shortint) lenmodline;
printl_(lnholdq, lenmodline);
/* Insert new stuff into bufq */
i__3 = ipbufmod;
/* Writing concatenation */
i__1[0] = ipbufmod, a__1[0] = inbuff_1.bufq;
i__1[1] = lenmodline, a__1[1] = lnholdq;
i__1[2] = lenbufmod - i__3, a__1[2] = inbuff_1.bufq + i__3;
s_cat(inbuff_1.bufq, a__1, i__1, &c__3, (ftnlen)65536);
/* Update internal parameters */
ipbufmod += inbuff_1.lbuf[ilbufmod - 1];
lenbufmod += inbuff_1.lbuf[ilbufmod - 1];
++inbuff_1.nlbuf;
/* L1: */
}
L3:
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "Closing ";
i__2[1] = lpmxmoddirq, a__2[1] = pmxmoddirq;
s_cat(ch__4, a__2, i__2, &c__2, (ftnlen)88);
printl_(ch__4, lpmxmoddirq + 8);
cl__1.cerr = 0;
cl__1.cunit = 18;
cl__1.csta = 0;
f_clos(&cl__1);
c1omget_1.linesinpmxmod = c1omget_1.linesinpmxmod + ilbufmod -
inbuff_1.ilbuf;
c1omget_1.lenbuf0 = lenbufmod;
/* Fix Andre's error reporting problem 101211 leading to log(neg#) due */
/* to nline being 2 bigger than it should be */
c1omget_1.nline += -2;
return 0;
} /* getpmxmod_ */
/* Subroutine */ int getset_(integer *nv, integer *noinst, integer *mtrnuml,
integer *mtrdenl, integer *mtrnmp, integer *mtrdnp, real *xmtrnum0,
integer *npages, integer *nsyst, integer *musicsize, real *fracindent,
logical *istype0, char *inameq, char *clefq, char *sepsymq, char *
pathnameq, integer *lpath, integer *isig0, ftnlen inameq_len, ftnlen
clefq_len, ftnlen sepsymq_len, ftnlen pathnameq_len)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
olist o__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *), s_wsfe(
cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_nint(real *), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, iv, ivi, nline;
static char lineq[128];
static integer iinst, jinst;
extern doublereal readin_(char *, integer *, integer *, ftnlen);
extern /* Subroutine */ int getbuf_(char *, ftnlen);
static logical newway;
static integer iccount, nvsofar;
/* Fortran I/O blocks */
static cilist io___837 = { 0, 17, 0, "(a)", 0 };
/* Get the first line */
/* Parameter adjustments */
--sepsymq;
--clefq;
inameq -= 79;
/* Function Body */
iccount = 0;
L9:
getbuf_(lineq, (ftnlen)128);
if (*(unsigned char *)lineq == '%') {
goto L9;
}
*istype0 = s_cmp(lineq, "---", (ftnlen)3, (ftnlen)3) == 0;
if (*istype0) {
/* Have TeX input until next line that starts with '---'. Save in scratch. */
o__1.oerr = 0;
o__1.ounit = 17;
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);
L3:
getbuf_(lineq, (ftnlen)128);
if (s_cmp(lineq, "---", (ftnlen)3, (ftnlen)3) != 0) {
s_wsfe(&io___837);
do_fio(&c__1, lineq, (ftnlen)128);
e_wsfe();
goto L3;
}
/* Force a new line read on first call to readin */
iccount = 128;
}
/* Here, lineq is first line w/ numerical setup data. */
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*nv = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*noinst = i_nint(&r__1);
newway = *noinst <= 0;
if (newway) {
*noinst = -(*noinst);
}
i__1 = *noinst;
for (iinst = 1; iinst <= i__1; ++iinst) {
/* Seve # of staves per inst in case later drop some inst's. */
if (newway) {
/* Read in nvi for each instrument */
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
comnvi_1.nsperi[iinst - 1] = i_nint(&r__1);
} else if (iinst > 1) {
comnvi_1.nsperi[iinst - 1] = 1;
} else {
comnvi_1.nsperi[iinst - 1] = *nv - *noinst + 1;
}
comnvi_1.iiorig[iinst - 1] = iinst;
comnvi_1.nspern[iinst - 1] = comnvi_1.nsperi[iinst - 1];
/* L2: */
}
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*mtrnuml = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*mtrdenl = i_nint(&r__1);
/* c */
/* c Kluge to make mtrdenl work */
/* c */
/* if (mtrdenl .eq. 1) then */
/* mtrdenl = 2 */
/* mtrnuml = mtrnuml*2 */
/* end if */
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*mtrnmp = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*mtrdnp = i_nint(&r__1);
*xmtrnum0 = readin_(lineq, &iccount, &nline, (ftnlen)128);
/* Original key sig (before any trnasposition) in next position. Transposed */
/* sig for topfile was transferred thru pmxtex.dat. Need isig0 for key */
/* changes if transposed. */
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*isig0 = i_nint(&r__1);
/* 130316 */
/* do 11 iinst = 1 , noinst */
/* midisig(iinst) = isig0 */
commidisig_1.midisig = *isig0;
/* 11 continue */
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*npages = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*nsyst = i_nint(&r__1);
r__1 = readin_(lineq, &iccount, &nline, (ftnlen)128);
*musicsize = i_nint(&r__1);
*fracindent = readin_(lineq, &iccount, &nline, (ftnlen)128);
/* Next noinst non-comment lines are names of instruments. */
i__1 = *noinst;
for (i__ = 1; i__ <= i__1; ++i__) {
L5:
getbuf_(inameq + i__ * 79, (ftnlen)79);
if (*(unsigned char *)&inameq[i__ * 79] == '%') {
goto L5;
}
/* L4: */
}
/* Mext non-comment line has nv clef names */
L6:
getbuf_(lineq, (ftnlen)128);
if (*(unsigned char *)lineq == '%') {
goto L6;
}
iv = 0;
nvsofar = 0;
i__1 = *noinst;
for (jinst = 1; jinst <= i__1; ++jinst) {
nvsofar += comnvi_1.nsperi[jinst - 1];
i__2 = comnvi_1.nsperi[jinst - 1];
for (ivi = 1; ivi <= i__2; ++ivi) {
++iv;
*(unsigned char *)&clefq[iv] = *(unsigned char *)&lineq[iv - 1];
if (iv == nvsofar) {
*(unsigned char *)&sepsymq[iv] = '&';
} else {
*(unsigned char *)&sepsymq[iv] = '|';
}
/* L10: */
}
/* L1: */
}
/* Mext non-comment line has path name */
L8:
getbuf_(pathnameq, (ftnlen)40);
if (*(unsigned char *)pathnameq == '%') {
goto L8;
}
*lpath = i_indx(pathnameq, " ", (ftnlen)40, (ftnlen)1) - 1;
return 0;
} /* getset_ */
doublereal getsquez_(integer *n, integer *ntot, real *space, real *tnote,
real *to)
{
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2;
/* Local variables */
static integer in;
static real tend, tgovern;
/* Get the squez factor by checking space against tgovern=minimum duration */
/* of all notes sounding at time of n-th note in the list. */
/* The starting time of base increment is to(n) and ending time is to(n)+space */
/* Sounding notes are those that start at or before to(n) .and. end at or */
/* after tend=to(n)+space */
/* Since notes are ordered by increasing start times, as soon as we find one */
/* that starts too late, we are done checking. */
/* Parameter adjustments */
--to;
--tnote;
/* Function Body */
tgovern = 1e3f;
tend = to[*n] + *space;
i__1 = *ntot;
for (in = 1; in <= i__1; ++in) {
/* Since to() is ordered by start times, exit loop after first note that */
/* starts later than note of interest. */
if (to[in] > to[*n] + comtol_1.tol) {
goto L2;
}
if (to[in] + tnote[in] > tend - comtol_1.tol) {
/* If here, this note overlaps and must be tested. */
/* Computing MIN */
r__1 = tgovern, r__2 = tnote[in];
tgovern = dmin(r__1,r__2);
}
/* L1: */
}
L2:
ret_val = *space / tgovern;
return ret_val;
} /* getsquez_ */
/* Subroutine */ int getx_(char *lineq, integer *iccount, integer *irest,
logical *shifton, real *wheadpt, integer *iornq1, integer *ivx,
integer *irest1, integer *itsofar, integer *ntup, integer *itup,
integer *nnodur, char *dotq, integer *ndoub, ftnlen lineq_len, ftnlen
dotq_len)
{
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static logical ess;
static real fnum;
static char durq[1], charq[1];
static logical colon, number;
static integer nextbl;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen);
extern integer ifnodur_(integer *, char *, ftnlen);
/* Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. */
/* In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. */
/* Since during getnote phase time is integer itsofar, which is not updated */
/* during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if */
/* not in xtup. */
colon = FALSE_;
ess = FALSE_;
number = FALSE_;
nextbl = *iccount + i_indx(lineq + (*iccount - 1), " ", 128 - (*iccount -
1), (ftnlen)1) - 1;
if (i_indx(lineq + (*iccount - 1), "P", nextbl - (*iccount - 1), (ftnlen)
1) > 0) {
/* "Parts only", ignore entire symbol */
*iccount = nextbl;
return 0;
}
L1:
getchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == 'B') {
/* "Both parts and score," ignore character */
goto L1;
} else if (*(unsigned char *)charq == ':') {
colon = TRUE_;
goto L1;
} else if (*(unsigned char *)charq == 'S') {
ess = TRUE_;
goto L1;
} else if (i_indx("+-.0123456789", charq, (ftnlen)13, (ftnlen)1) > 0) {
number = TRUE_;
if (*(unsigned char *)charq == '-') {
++(*iccount);
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == '-') {
fnum = -fnum;
}
if (*(unsigned char *)durq != 'p') {
fnum *= *wheadpt;
--(*iccount);
}
goto L1;
}
/* charq must be blank, so done parsing */
if (! ess && ! colon) {
/* Ordinary hardspace. Goes before next note. */
/* (Later, at "|" or "/", check for presence and switch to udoff if there!) */
++comudsp_1.nudsp;
*iornq1 = bit_set(*iornq1,26);
comudsp_1.udsp[comudsp_1.nudsp - 1] = fnum;
comudsp_1.tudsp[comudsp_1.nudsp - 1] = (real) (*itsofar);
if (*ntup > 0) {
comudsp_1.tudsp[comudsp_1.nudsp - 1] += (real) (*itup - 1 + *
ndoub) / *ntup * ifnodur_(nnodur, dotq, (ftnlen)1);
}
/* * +float(itup-1)/ntup*ifnodur(nnodur,dotq) */
} else if (! number) {
/* Must be "X:" End a group offset. */
*irest = bit_set(*irest,17);
*shifton = FALSE_;
return 0;
} else {
/* Only other possibility is start offset, "S" for single, ':' for multiple */
++comudsp_1.nudoff[*ivx - 1];
comudsp_1.udoff[*ivx + comudsp_1.nudoff[*ivx - 1] * 24 - 25] = fnum;
if (ess) {
*irest1 = bit_set(*irest1,15);
} else {
*irest1 = bit_set(*irest1,16);
*shifton = TRUE_;
}
}
return 0;
} /* getx_ */
integer i1fnodur_(integer *idur, char *dotq, ftnlen dotq_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen);
/* Local variables */
extern /* Subroutine */ int stop1_(void);
/* Fortran I/O blocks */
static cilist io___856 = { 0, 6, 0, 0, 0 };
static cilist io___857 = { 0, 6, 0, 0, 0 };
if (*idur == 6) {
ret_val = 1;
} else if (*idur == 3) {
ret_val = 2;
} else if (*idur == 1) {
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 if (*idur == 16) {
/* Only used for denominator of time signatures, not for notes */
ret_val = 4;
} else if (*idur == 9) {
ret_val = 128;
} else {
s_wsle(&io___856);
e_wsle();
s_wsle(&io___857);
do_lio(&c__9, &c__1, "You entered an invalid note-length value:", (
ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*idur), (ftnlen)sizeof(integer));
e_wsle();
stop1_();
}
if (*(unsigned char *)dotq == 'd') {
ret_val = ret_val * 3 / 2;
}
return ret_val;
} /* i1fnodur_ */
/* integer*4 function longi(ishort) */
/* integer*2 ishort */
/* longi = ishort */
/* return */
/* end */
integer iashft_(integer *nacc)
{
/* Initialized data */
static integer ias[6] = { -1,1,0,0,-2,2 };
/* System generated locals */
integer ret_val;
ret_val = ias[(0 + (0 + (*nacc - 1 << 2))) / 4];
return ret_val;
} /* iashft_ */
integer ifnodur_(integer *idur, char *dotq, ftnlen dotq_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___859 = { 0, 6, 0, 0, 0 };
if (*idur == 6) {
ret_val = 1;
} else if (*idur == 3) {
ret_val = 2;
} else if (*idur == 1) {
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 if (*idur == 9) {
ret_val = 128;
} else if (*idur == 16) {
/* Only used for denominator of time signatures, not for notes */
ret_val = 4;
} else {
s_wsle(&io___859);
do_lio(&c__9, &c__1, "You entered an invalid note value", (ftnlen)33);
e_wsle();
s_stop("", (ftnlen)0);
}
if (*(unsigned char *)dotq == 'd') {
ret_val = ret_val * 3 / 2;
}
return ret_val;
} /* ifnodur_ */
integer ifnolev_(char *noq, integer *oct, integer *ntrans, ftnlen noq_len)
{
/* System generated locals */
integer ret_val;
ret_val = *oct * 7 + (*(unsigned char *)noq - 92) % 7 + 1 + *ntrans;
return ret_val;
} /* ifnolev_ */
/* subroutine report(nsdat,isdat1,isdat2) */
/* integer*4 isdat1(202),isdat2(202) */
/* write(*,'(a)') */
/* * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' */
/* do 1 isdat = 1 , nsdat */
/* isdata = isdat1(isdat) */
/* ionoff = igetbits(isdata,1,11) */
/* c iv = iand(7,isdata) */
/* iv = igetbits(isdata,5,13) */
/* kv = igetbits(isdata,1,12)+1 */
/* ip = igetbits(isdata,8,3) */
/* idcode = igetbits(isdata,7,19) */
/* iud1 = igetbits(isdata,1,26) */
/* iud2 = igetbits(isdata,1,27) */
/* ndxslur = igetbits(isdata,4,28) */
/* isdatb = isdat2(isdat) */
/* ivo = igetbits(isdatb,6,6)-32 */
/* iho = igetbits(isdatb,7,12)-64 */
/* lev = igetbits(isdatb,7,19) */
/* icrd = igetbits(isdatb,1,0) */
/* lhd = igetbits(isdatb,1,1) */
/* irhd = igetbits(isdatb,7,2) */
/* write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, */
/* * ivo,iho,lev,icrd,lhd,irhd */
/* 1 continue */
/* print* */
/* return */
/* end */
integer igetbits_(integer *isdata, integer *iwidbit, integer *ishift)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer pow_ii(integer *, integer *), lbit_shift(integer, integer);
/* Extracts integer given by iwidbit bits of isdata, shifted by ishift, and */
/* then added to ioff */
ret_val = pow_ii(&c__2, iwidbit) - 1 & lbit_shift(*isdata, -(*ishift));
return ret_val;
} /* igetbits_ */
integer igetvarlen_(shortint *mmidi, integer *icm, integer *imidi, integer *
nbytes)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
extern /* Subroutine */ int stop1_(void);
/* Fortran I/O blocks */
static cilist io___860 = { 0, 6, 0, 0, 0 };
/* Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. */
/* Parameter adjustments */
mmidi -= 25;
/* Function Body */
ret_val = 0;
for (*nbytes = 1; *nbytes <= 4; ++(*nbytes)) {
ret_val = (ret_val << 7) + (127 & mmidi[*icm + (*imidi + *nbytes) *
25]);
/* * +iand(127,longi(mmidi(icm,imidi+nbytes))) */
if (! bit_test(mmidi[*icm + (*imidi + *nbytes) * 25],7)) {
return ret_val;
}
/* if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return */
/* L1: */
}
s_wsle(&io___860);
do_lio(&c__9, &c__1, "Messup in igetvarlen", (ftnlen)20);
e_wsle();
stop1_();
return ret_val;
} /* igetvarlen_ */
logical isdotted_(integer *nodur, integer *ivx, integer *ip)
{
/* System generated locals */
real r__1;
logical ret_val;
/* Builtin functions */
double log(doublereal), r_mod(real *, real *);
/* Function returns true if note is dotted or double-dotted. */
/* Return false for any xtuplet. */
/* Parameter adjustments */
nodur -= 25;
/* Function Body */
if (nodur[*ivx + *ip * 24] == 0) {
ret_val = FALSE_;
return ret_val;
} else if (*ip > 1) {
if (nodur[*ivx + (*ip - 1) * 24] == 0) {
ret_val = FALSE_;
return ret_val;
}
}
/* Ruled out all xtups, so is dotted or double-dotted if not a power of 2. */
r__1 = log((real) nodur[*ivx + *ip * 24]) / .69314718f + comtol_1.tol *
.5f;
ret_val = r_mod(&r__1, &c_b807) > comtol_1.tol;
return ret_val;
} /* isdotted_ */
integer isetvarlen_(integer *idur, integer *nbytes)
{
/* System generated locals */
integer ret_val, i__1;
/* Builtin functions */
integer pow_ii(integer *, integer *), lbit_shift(integer, integer),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
extern /* Subroutine */ int stop1_(void);
static integer itemp;
/* Fortran I/O blocks */
static cilist io___862 = { 0, 6, 0, 0, 0 };
ret_val = 0;
itemp = *idur;
for (*nbytes = 1; *nbytes <= 4; ++(*nbytes)) {
i__1 = *nbytes - 1;
ret_val += (itemp & 127) * pow_ii(&c__256, &i__1);
itemp = lbit_shift(itemp, (ftnlen)-7);
if (itemp > 0) {
i__1 = (*nbytes << 3) + 7;
ret_val += pow_ii(&c__2, &i__1);
} else {
return ret_val;
}
/* L1: */
}
s_wsle(&io___862);
do_lio(&c__9, &c__1, "Problem in function isetvarlen", (ftnlen)30);
e_wsle();
stop1_();
return ret_val;
} /* isetvarlen_ */
/* Subroutine */ int istring_(integer *i__, char *string, integer *len,
ftnlen string_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1[3], i__2[2];
real r__1;
char ch__1[1], ch__2[4];
icilist ici__1;
/* Builtin functions */
double r_lg10(real *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Returns string with integer only if length is 1, otherwise enclosed in */
/* brackets. */
if (*i__ != 0) {
r__1 = abs(*i__) * 1.0001f;
*len = r_lg10(&r__1) + 1;
if (*i__ < 0) {
++(*len);
}
} else {
s_copy(string, "0", string_len, (ftnlen)1);
*len = 1;
return 0;
}
if (*len == 1) {
*(unsigned char *)&ch__1[0] = *i__ + 48;
s_copy(string, ch__1, string_len, (ftnlen)1);
} else {
s_copy(string, "{", string_len, (ftnlen)1);
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *len;
ici__1.iciunit = string + 1;
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "(i";
*(unsigned char *)&ch__1[0] = *len + 48;
i__1[1] = 1, a__1[1] = ch__1;
i__1[2] = 1, a__1[2] = ")";
ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)4), ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = *len + 1, a__2[0] = string;
i__2[1] = 1, a__2[1] = "}";
s_cat(string, a__2, i__2, &c__2, string_len);
*len += 2;
}
return 0;
} /* istring_ */
integer lenstr_(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_ */
integer levrn_(integer *nolev, integer *irest, integer *iud, integer *ncm,
integer *mult)
{
/* System generated locals */
integer ret_val;
/* Local variables */
static integer ioff;
/* Used for placing numbers in xtups. Returns note level if not a rest, */
/* else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. */
if (! bit_test(*irest,0)) {
ret_val = *nolev;
} else {
/* Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. */
if (*mult > 0) {
if (*mult == 2) {
ioff = (*iud << 1) - 1;
} else if (*mult != 4) {
ioff = *iud * *mult;
} else {
ioff = (*iud << 2) + 1;
}
} else {
/* May need to futz with this later for non-beamed xtups (quarter, half rests) */
ioff = *iud << 1;
}
ret_val = (*nolev + 20) % 100 - 20 + *ncm + ioff;
}
return ret_val;
} /* levrn_ */
integer lfmt1_(real *x)
{
/* System generated locals */
integer ret_val;
real r__1;
/* Builtin functions */
double r_sign(real *, real *), r_lg10(real *);
/* Local variables */
static real y;
/* Computes total length of an "f" format with one decimal place. */
/* First round to nearest 0.1 */
if (dabs(*x) < .001f) {
ret_val = 2;
} else {
r__1 = (integer) (dabs(*x) * 10 + .5f) * .1f;
y = r_sign(&r__1, x);
r__1 = dabs(y) * 1000 + .001f;
ret_val = (integer) r_lg10(&r__1);
if (y < 0.f) {
++ret_val;
}
}
return ret_val;
} /* lfmt1_ */
/* Subroutine */ int linebreakties_(integer *isdat1, integer *isdat2, integer
*isdat3, integer *isdat4, integer *nsdat, logical *ispstie, char *
sepsymq, ftnlen sepsymq_len)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[5], a__4[4];
integer i__1, i__2[2], i__3[3], i__4[5], i__5[4];
real r__1;
char ch__1[1], ch__2[1];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
extern /* Subroutine */ int writflot_(real *, char *, integer *, ftnlen);
static integer iv, kv, ncm;
static logical tie;
static integer iiv;
static char udq[1];
static integer ndx, ilb12;
static real hoff;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer imid, ihoff, isdat, ivoff, lnote;
static char noteq[8];
static integer idcode, islhgt;
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten;
static char notexq[128];
/* Fortran I/O blocks */
static cilist io___884 = { 0, 11, 0, "(a)", 0 };
/* This is called twice from pmxb after having input an entire block, before */
/* making a bar that starts a new system. So nsdat reflects all slur starts */
/* and stops in new block, while listslur, which is only set when bars are */
/* made, reflects only open slurs from the old block. So we must check */
/* listslur to find open ties, not all nsdat. */
/* First of two calls (ispstie=.false. on entry) terminates tie at end of line. */
/* Second (ispstie=.true. on entry) restarts tie at start of new line. Only */
/* need data from original tie-start for both of these. Tie/slur data from */
/* closing of full tie are not used except for shape alterations. */
/* do 1 ndx = 0 , 11 */
/* Parameter adjustments */
--sepsymq;
--isdat4;
--isdat3;
--isdat2;
--isdat1;
/* Function Body */
for (ndx = 0; ndx <= 23; ++ndx) {
if (bit_test(comslur_1.listslur,ndx)) {
/* Slur or tie with index ndx is open. Find the one with right ndxb, see if tie */
i__1 = *nsdat;
for (isdat = 1; isdat <= i__1; ++isdat) {
/* if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index */
if (igetbits_(&isdat1[isdat], &c__4, &c__28) + (igetbits_(&
isdat1[isdat], &c__1, &c__18) << 4) != ndx) {
goto L2;
}
/* Wron */
if (! bit_test(isdat1[isdat],11)) {
goto L2;
}
/* Bypass if stop */
if (bit_test(isdat2[isdat],3)) {
goto L3;
}
/* "st" */
idcode = igetbits_(&isdat1[isdat], &c__7, &c__19);
if (idcode == 1) {
goto L3;
}
/* "t" */
tie = FALSE_;
goto L5;
L2:
;
}
}
goto L1;
L3:
tie = TRUE_;
L5:
/* A slur or tie is open, with index ndx */
iv = igetbits_(&isdat1[isdat], &c__5, &c__13);
kv = igetbits_(&isdat1[isdat], &c__1, &c__12) + 1;
*(unsigned char *)udq = 'd';
if (bit_test(isdat1[isdat],27)) {
*(unsigned char *)udq = 'u';
}
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 6, a__1[1] = "znotes";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
lnote = 7;
i__1 = iv - 1;
for (iiv = 1; iiv <= i__1; ++iiv) {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = sepsymq + iiv;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
/* L4: */
}
if (kv == 2) {
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 9, a__2[2] = "nextvoice";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 10;
}
/* Compute horiz and vert offsets */
/* nolev = igetbits(isdat2(isdat),7,19) */
islhgt = igetbits_(&isdat3[isdat], &c__8, &c__14);
ilb12 = 0;
if (*ispstie) {
ilb12 = 1;
}
i__1 = ilb12 << 4;
ivoff = igetbits_(&isdat4[isdat], &c__6, &i__1) - 32;
if (ivoff == -32) {
ivoff = 0;
}
/* nolev = nolev+ivoff */
islhgt += ivoff;
i__1 = (ilb12 << 4) + 6;
ihoff = igetbits_(&isdat4[isdat], &c__7, &i__1) - 64;
/* This is 10X */
if (ihoff == -64) {
ihoff = 0;
}
/* Add starting stuff for command */
if (! (*ispstie)) {
/* End 1st segment */
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 8, a__2[2] = "roffset{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 9;
/* hoff = ihoff*.1-.5 */
/* hoff = ihoff*.1-.8 */
hoff = ihoff * .1f - .4f;
if (hoff < 0.f) {
hoff = -hoff;
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "-";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
}
writflot_(&hoff, notexq, &lnote, (ftnlen)128);
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 2, a__1[1] = "}{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
lnote += 2;
} else {
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 5, a__3[2] = "off{-";
chax_(ch__2, (ftnlen)1, &c__92);
i__4[3] = 1, a__3[3] = ch__2;
i__4[4] = 14, a__3[4] = "afterruleskip}";
s_cat(notexq, a__3, i__4, &c__5, (ftnlen)128);
lnote += 21;
/* 091025 add dotting for 2nd segment if needed */
if (bit_test(isdat2[isdat],4)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__2[0] = ch__1;
i__3[1] = 6, a__2[1] = "dotted";
i__3[2] = lnote, a__2[2] = notexq;
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 7;
}
}
if (*ispstie && tie) {
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__5[1] = 1, a__4[1] = ch__1;
i__5[2] = 8, a__4[2] = "tieforis";
i__5[3] = 1, a__4[3] = udq;
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote += 10;
}
if (bit_test(isdat3[isdat],0)) {
/* Curvature tweak on termination of 1st seg */
imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32;
/* Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: */
/* Abs(imid) Postscript slur type */
/* 1 f */
/* 4 h */
/* 5 H */
/* 6 HH */
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__5[1] = 1, a__4[1] = ch__1;
i__5[2] = 7, a__4[2] = "psforts";
i__1 = imid + 48;
chax_(ch__2, (ftnlen)1, &i__1);
i__5[3] = 1, a__4[3] = ch__2;
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote += 9;
/* Zero out the flag in case there's a different curv on term of 2nd, */
isdat3[isdat] = bit_clear(isdat3[isdat],0);
}
/* Add the command name */
if (*ispstie) {
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__5[1] = 1, a__4[1] = ch__1;
i__5[2] = 2, a__4[2] = "is";
i__5[3] = 1, a__4[3] = udq;
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote += 4;
} else if (tie) {
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 4, a__2[2] = "ttie";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 5;
} else {
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 5, a__2[2] = "tslur";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 6;
}
/* Add index */
/* if (11-ndx .lt. 10) then */
/* notexq = notexq(1:lnote)//chax(59-ndx) */
/* lnote = lnote+1 */
/* else */
/* notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' */
/* lnote = lnote+4 */
/* end if */
if (23 - ndx < 10) {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__1 = 71 - ndx;
chax_(ch__1, (ftnlen)1, &i__1);
i__2[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
} else if (23 - ndx < 20) {
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
i__5[1] = 2, a__4[1] = "{1";
i__1 = 61 - ndx;
chax_(ch__1, (ftnlen)1, &i__1);
i__5[2] = 1, a__4[2] = ch__1;
i__5[3] = 1, a__4[3] = "}";
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote += 4;
} else {
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
i__5[1] = 2, a__4[1] = "{2";
i__1 = 51 - ndx;
chax_(ch__1, (ftnlen)1, &i__1);
i__5[2] = 1, a__4[2] = ch__1;
i__5[3] = 1, a__4[3] = "}";
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote += 4;
}
if (*ispstie || ! tie) {
/* Add note name for slur height */
comoct_1.noctup = 0;
ncm = igetbits_(&isdat3[isdat], &c__8, &c__22);
if (ncm == 23) {
comoct_1.noctup = -2;
}
/* call notefq(noteq,lnoten,nolev,ncm) */
notefq_(noteq, &lnoten, &islhgt, &ncm, (ftnlen)8);
/* Writing concatenation */
i__5[0] = lnote, a__4[0] = notexq;
i__5[1] = 1, a__4[1] = "{";
i__5[2] = lnoten, a__4[2] = noteq;
i__5[3] = 1, a__4[3] = "}";
s_cat(notexq, a__4, i__5, &c__4, (ftnlen)128);
lnote = lnote + 1 + lnoten + 1;
}
if (*ispstie) {
/* Horizontal shift start of new thing */
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
/* ihoff = ihoff-13 */
if (tie) {
ihoff += -12;
} else {
ihoff += -7;
}
if (ihoff < 0) {
ihoff = -ihoff;
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "-";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
}
r__1 = ihoff * .1f;
writflot_(&r__1, notexq, &lnote, (ftnlen)128);
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
}
/* Add closing stuff */
if (*ispstie) {
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 4, a__3[2] = "off{";
chax_(ch__2, (ftnlen)1, &c__92);
i__4[3] = 1, a__3[3] = ch__2;
i__4[4] = 14, a__3[4] = "afterruleskip}";
s_cat(notexq, a__3, i__4, &c__5, (ftnlen)128);
lnote += 20;
} else {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)128);
++lnote;
}
/* Writing concatenation */
i__3[0] = lnote, a__2[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__2[1] = ch__1;
i__3[2] = 3, a__2[2] = "en%";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)128);
lnote += 4;
s_wsfe(&io___884);
do_fio(&c__1, notexq, lnote);
e_wsfe();
L1:
;
}
*ispstie = ! (*ispstie);
return 0;
} /* linebreakties_ */
/* Subroutine */ int littex_(integer *islur, integer *nnl, integer *iv,
logical *topmods, char *lineq, integer *iccount, ftnlen lineq_len)
{
/* System generated locals */
address a__1[2], a__2[3];
integer i__1[2], i__2[3];
char ch__1[1], ch__2[129];
olist o__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void), f_open(olist *);
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char durq[1];
extern /* Subroutine */ int stop1_(void);
static logical merge;
static integer itype;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen);
/* Fortran I/O blocks */
static cilist io___888 = { 0, 6, 0, 0, 0 };
static cilist io___889 = { 0, 6, 0, 0, 0 };
static cilist io___890 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___891 = { 0, 11, 0, "(a)", 0 };
static cilist io___892 = { 0, 16, 0, "(a)", 0 };
/* Parameter adjustments */
islur -= 25;
/* Function Body */
merge = FALSE_;
if (comgrace_1.nlit > 0) {
merge = *iv == comgrace_1.ivlit[comgrace_1.nlit - 1] && *nnl ==
comgrace_1.iplit[comgrace_1.nlit - 1];
}
++comgrace_1.nlit;
comgrace_1.ivlit[comgrace_1.nlit - 1] = *iv;
comgrace_1.iplit[comgrace_1.nlit - 1] = *nnl;
itype = 1;
L17:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
chax_(ch__1, (ftnlen)1, &c__92);
if (*(unsigned char *)durq == *(unsigned char *)&ch__1[0]) {
++itype;
goto L17;
}
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 1, a__1[1] = durq;
s_cat(comgrace_1.litq + (comgrace_1.nlit - 1 << 7), a__1, i__1, &c__2, (
ftnlen)128);
comgrace_1.lenlit[comgrace_1.nlit - 1] = 2;
L18:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
chax_(ch__1, (ftnlen)1, &c__92);
if (*(unsigned char *)durq == *(unsigned char *)&ch__1[0]) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq != ' ') {
/* Starting a new tex command within the string */
/* Writing concatenation */
i__2[0] = comgrace_1.lenlit[comgrace_1.nlit - 1], a__2[0] =
comgrace_1.litq + (comgrace_1.nlit - 1 << 7);
chax_(ch__1, (ftnlen)1, &c__92);
i__2[1] = 1, a__2[1] = ch__1;
i__2[2] = 1, a__2[2] = durq;
s_cat(comgrace_1.litq + (comgrace_1.nlit - 1 << 7), a__2, i__2, &
c__3, (ftnlen)128);
comgrace_1.lenlit[comgrace_1.nlit - 1] += 2;
goto L18;
}
} else {
/* Writing concatenation */
i__1[0] = comgrace_1.lenlit[comgrace_1.nlit - 1], a__1[0] =
comgrace_1.litq + (comgrace_1.nlit - 1 << 7);
i__1[1] = 1, a__1[1] = durq;
s_cat(comgrace_1.litq + (comgrace_1.nlit - 1 << 7), a__1, i__1, &c__2,
(ftnlen)128);
++comgrace_1.lenlit[comgrace_1.nlit - 1];
goto L18;
}
/* If here, just read backslash-blank so string is done */
if (itype == 1) {
islur[*iv + *nnl * 24] = bit_set(islur[*iv + *nnl * 24],16);
if (merge) {
/* There are 2 separate strings on the same note, so merge them. */
--comgrace_1.nlit;
/* Writing concatenation */
i__1[0] = comgrace_1.lenlit[comgrace_1.nlit - 1], a__1[0] =
comgrace_1.litq + (comgrace_1.nlit - 1 << 7);
i__1[1] = comgrace_1.lenlit[comgrace_1.nlit], a__1[1] =
comgrace_1.litq + (comgrace_1.nlit << 7);
s_cat(comgrace_1.litq + (comgrace_1.nlit - 1 << 7), a__1, i__1, &
c__2, (ftnlen)128);
comgrace_1.lenlit[comgrace_1.nlit - 1] += comgrace_1.lenlit[
comgrace_1.nlit];
if (comgrace_1.lenlit[comgrace_1.nlit - 1] > 128) {
s_wsle(&io___888);
e_wsle();
s_wsle(&io___889);
do_lio(&c__9, &c__1, "Merged type-1 TeX strings longer than "
"128 characters", (ftnlen)52);
e_wsle();
s_wsfe(&io___890);
do_fio(&c__1, "Merged type-1 TeX strings longer than 128 cha"
"racters", (ftnlen)52);
e_wsfe();
stop1_();
}
}
} else {
if (itype == 3) {
/* Write the string NOW */
if (comlast_1.islast) {
s_wsfe(&io___891);
/* Writing concatenation */
i__1[0] = comgrace_1.lenlit[comgrace_1.nlit - 1], a__1[0] =
comgrace_1.litq + (comgrace_1.nlit - 1 << 7);
i__1[1] = 1, a__1[1] = "%";
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)129);
do_fio(&c__1, ch__2, comgrace_1.lenlit[comgrace_1.nlit - 1] +
1);
e_wsfe();
}
} else {
/* Must go at top */
if (! (*topmods)) {
*topmods = TRUE_;
o__1.oerr = 0;
o__1.ounit = 16;
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);
}
/* Must write '%' here rather than later, in case string ends with blank. */
s_wsfe(&io___892);
/* Writing concatenation */
i__1[0] = comgrace_1.lenlit[comgrace_1.nlit - 1], a__1[0] =
comgrace_1.litq + (comgrace_1.nlit - 1 << 7);
i__1[1] = 1, a__1[1] = "%";
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)129);
do_fio(&c__1, ch__2, comgrace_1.lenlit[comgrace_1.nlit - 1] + 1);
e_wsfe();
}
--comgrace_1.nlit;
}
return 0;
} /* littex_ */
integer llen_(char *strq, integer *n, ftnlen strq_len)
{
/* System generated locals */
integer ret_val;
for (ret_val = *n; ret_val >= 0; --ret_val) {
if (*(unsigned char *)&strq[ret_val - 1] != ' ') {
return ret_val;
}
/* L1: */
}
return ret_val;
} /* llen_ */
integer log2_(integer *n)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
double log(doublereal);
/* 5/25/08 Modify to allow more slurs */
/* log2 = alog(1.*n)/0.6931472+.0001 */
/* log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 */
ret_val = (integer) (log(*n * 1.) / .693147181 + 2e-8);
return ret_val;
} /* log2_ */
/* Subroutine */ int logbeam_(integer *numnew, integer *nip1, integer *nip2)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
char ch__1[1];
/* Builtin functions */
double log(doublereal);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static integer ib, iip;
static real sum;
static integer iip1;
extern integer log2_(integer *);
static integer iiip;
extern /* Character */ VOID ulfq_(char *, ftnlen, real *, integer *);
extern integer ncmid_(integer *, integer *);
static integer ndoub, multx, nrests, numnow;
static logical isxtup;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
all_1.ibm1[commvl_1.ivx + *numnew * 24 - 25] = *nip1;
all_1.ibm2[commvl_1.ivx + *numnew * 24 - 25] = *nip2;
numnow = *numnew;
if (*numnew > 1) {
/* If it starts before any others, must put it in order */
for (ib = *numnew - 1; ib >= 1; --ib) {
if (all_1.ibm1[commvl_1.ivx + ib * 24 - 25] < *nip1) {
goto L12;
}
all_1.ibm1[commvl_1.ivx + (ib + 1) * 24 - 25] = all_1.ibm1[
commvl_1.ivx + ib * 24 - 25];
all_1.ibm2[commvl_1.ivx + (ib + 1) * 24 - 25] = all_1.ibm2[
commvl_1.ivx + ib * 24 - 25];
*(unsigned char *)&all_1.ulq[commvl_1.ivx + (ib + 1) * 24 - 25] =
*(unsigned char *)&all_1.ulq[commvl_1.ivx + ib * 24 - 25];
all_1.ibm1[commvl_1.ivx + ib * 24 - 25] = *nip1;
all_1.ibm2[commvl_1.ivx + ib * 24 - 25] = *nip2;
numnow = ib;
/* L11: */
}
L12:
;
}
sum = 0.f;
/* Beam has non-xtup within */
nrests = 0;
isxtup = FALSE_;
i__1 = *nip2;
for (iip = *nip1; iip <= i__1; ++iip) {
if (bit_test(all_1.islur[commvl_1.ivx + *nip1 * 24 - 25],21)) {
/* Forced multiplicity */
/* mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) */
i__2 = igetbits_(&all_1.islur[commvl_1.ivx + *nip1 * 24 - 25], &
c__3, &c__22) + 8;
setbits_(&all_1.mult[commvl_1.ivx + iip * 24 - 25], &c__4, &c__0,
&i__2);
} else if (! isxtup) {
if (all_1.nodur[commvl_1.ivx + iip * 24 - 25] > 0) {
/* mult(ivx,iip) = 4-log2(nodur(ivx,iip)) */
i__2 = 4 - log2_(&all_1.nodur[commvl_1.ivx + iip * 24 - 25])
+ 8;
setbits_(&all_1.mult[commvl_1.ivx + iip * 24 - 25], &c__4, &
c__0, &i__2);
} else {
/* Start xtup within forced beam */
isxtup = TRUE_;
iip1 = iip;
}
} else if (isxtup && all_1.nodur[commvl_1.ivx + iip * 24 - 25] > 0) {
/* End of xtup within forced beam. Must count doubled notes */
ndoub = 0;
i__2 = iip;
for (iiip = iip1; iiip <= i__2; ++iiip) {
if (bit_test(all_1.nacc[commvl_1.ivx + iiip * 24 - 25],18)) {
++ndoub;
}
/* L1: */
}
multx = (integer) ((log(iip + 1.f - iip1 + ndoub) * .952f - log(
all_1.nodur[commvl_1.ivx + iip * 24 - 25] / 2.f)) /
.69315f + 13.429f) - 10;
i__2 = iip;
for (iiip = iip1; iiip <= i__2; ++iiip) {
/* mult(ivx,iiip) = multx */
i__3 = multx + 8;
setbits_(&all_1.mult[commvl_1.ivx + iiip * 24 - 25], &c__4, &
c__0, &i__3);
/* Note the following still works after making mult only the 1st 4 bits. */
if (bit_test(all_1.nacc[commvl_1.ivx + iiip * 24 - 25],18)) {
--all_1.mult[commvl_1.ivx + iiip * 24 - 25];
}
if (bit_test(all_1.nacc[commvl_1.ivx + iiip * 24 - 25],19)) {
++all_1.mult[commvl_1.ivx + iiip * 24 - 25];
} else if (iiip > 1) {
if (bit_test(all_1.nacc[commvl_1.ivx + (iiip - 1) * 24 -
25],19)) {
++all_1.mult[commvl_1.ivx + iiip * 24 - 25];
}
}
/* L74: */
}
isxtup = FALSE_;
}
if (bit_test(all_1.irest[commvl_1.ivx + iip * 24 - 25],0)) {
++nrests;
} else {
sum += all_1.nolev[commvl_1.ivx + iip * 24 - 25];
}
/* L9: */
}
/* Set beam up-down-ness */
if (comfb_1.ifb > 0 && *(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx +
max(1,comfb_1.ifb) * 24 - 25] != 'x') {
if (*(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx + comfb_1.ifb * 24
- 25] == 'f') {
/* Get default, then trade "l" and "u" */
r__1 = sum / (*nip2 - *nip1 + 1 - nrests);
i__1 = ncmid_(&all_1.iv, nip1);
ulfq_(ch__1, (ftnlen)1, &r__1, &i__1);
*(unsigned char *)&all_1.ulq[commvl_1.ivx + numnow * 24 - 25] = (
char) (225 - *(unsigned char *)&ch__1[0]);
} else {
*(unsigned char *)&all_1.ulq[commvl_1.ivx + comfb_1.ifb * 24 - 25]
= *(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx +
comfb_1.ifb * 24 - 25];
}
/* This probably works only because forced beams are done first, so they */
/* don't have to be re-sorted within each voice. ???? */
} else if (commvl_1.nvmx[all_1.iv - 1] == 2) {
/* Multi-voice per staff */
if (commvl_1.ivx <= all_1.nv) {
*(unsigned char *)&all_1.ulq[commvl_1.ivx + numnow * 24 - 25] =
'l';
} else {
*(unsigned char *)&all_1.ulq[commvl_1.ivx + numnow * 24 - 25] =
'u';
}
} else {
/* Defaults */
r__1 = sum / (*nip2 - *nip1 + 1 - nrests);
i__1 = ncmid_(&all_1.iv, nip1);
ulfq_(ch__1, (ftnlen)1, &r__1, &i__1);
*(unsigned char *)&all_1.ulq[commvl_1.ivx + numnow * 24 - 25] = *(
unsigned char *)&ch__1[0];
}
return 0;
} /* logbeam_ */
/* Subroutine */ int m1rec1_(char *lineq, integer *iccount, integer *ibarcnt,
integer *ibaroff, integer *nbars, integer *ndxm, ftnlen lineq_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int stop1_(void), errmsg_(char *, integer *,
integer *, char *, ftnlen, ftnlen);
extern integer ntindex_(char *, char *, integer *, ftnlen, ftnlen);
/* This is called when (a) macro recording is just starting and */
/* (b) at the start of a new line, if recording is on */
inbuff_1.lbuf[0] = inbuff_1.lbuf[0];
if (! commac_1.mrecord) {
/* Starting the macro */
c1ommac_1.ip1mac[commac_1.macnum - 1] = inbuff_1.ipbuf -
inbuff_1.lbuf[inbuff_1.ilbuf - 2] + *iccount;
c1ommac_1.il1mac[commac_1.macnum - 1] = inbuff_1.ilbuf - 1;
c1ommac_1.ic1mac[commac_1.macnum - 1] = *iccount;
commac_1.mrecord = TRUE_;
}
if (*iccount < 128) {
i__1 = *iccount;
*ndxm = i_indx(lineq + i__1, "M", 128 - i__1, (ftnlen)1);
if (*ndxm > 0) {
i__1 = *iccount;
i__2 = 128 - *iccount;
*ndxm = ntindex_(lineq + i__1, "M", &i__2, 128 - i__1, (ftnlen)1);
}
if (*ndxm > 0) {
/* This line ends the macro. */
i__1 = *iccount + *ndxm;
if (s_cmp(lineq + i__1, " ", *iccount + *ndxm + 1 - i__1, (ftnlen)
1) != 0) {
i__1 = *iccount + *ndxm + 1;
i__2 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__1, &i__2, "Improper macro termination!", (
ftnlen)128, (ftnlen)27);
stop1_();
}
c1ommac_1.ip2mac[commac_1.macnum - 1] = inbuff_1.ipbuf -
inbuff_1.lbuf[inbuff_1.ilbuf - 2] + *iccount + *ndxm;
c1ommac_1.il2mac[commac_1.macnum - 1] = inbuff_1.ilbuf - 1;
commac_1.mrecord = FALSE_;
}
}
return 0;
} /* m1rec1_ */
/* Subroutine */ int make1bar_(integer *ibmrep, real *tglp1, real *tstart,
logical *cwrest, real *squez, integer *istop, integer *numbms,
integer *istart)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Local variables */
extern /* Subroutine */ int findbeam_(integer *, integer *, integer *);
extern integer igetbits_(integer *, integer *, integer *);
extern doublereal getsquez_(integer *, integer *, real *, real *, real *);
static integer ib, in, ip, kp, kv, ib1, ib2, ip1, cnn[24], inj, iin, iiv,
isl;
static real xit[24];
extern doublereal feon_(real *);
static integer irep;
static real tmin;
static integer iivx, itbb1, itbb2, itbb3, inip1;
static real tglp2;
extern /* Subroutine */ int addfb_(integer *, integer *, real *, real *,
real *, char *, integer *, ftnlen);
static integer mapfb[16];
static real deskb;
extern doublereal fnote_(integer *, integer *, integer *, integer *);
static real eskzb;
static integer ibrep;
static real tminn;
static integer nxtup, nip1fb, nip2fb, ib1now, ib2now, ifbadd;
static real t1xtup[20];
static integer nfbbar;
static logical infbmx[24];
static integer ifbnow[24], numnew;
static logical inxtup[24];
static integer mapnow, nxtnow[24];
static real xsquez;
extern /* Subroutine */ int logbeam_(integer *, integer *, integer *),
setbits_(integer *, integer *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___937 = { 0, 6, 0, 0, 0 };
static cilist io___938 = { 0, 6, 0, 0, 0 };
static cilist io___939 = { 0, 15, 0, "(/a)", 0 };
/* Above are factors for grace note, clef spacing. (fraction of wheadpt) */
/* In 1.04, moved to block data subprogram */
/* Parameter adjustments */
--istart;
--numbms;
--istop;
--squez;
--cwrest;
--tstart;
/* Function Body */
if (commidi_1.ismidi) {
/* Initialize for this bar the accidental counter for the midi file. */
/* naccim(icm) = # of accidentals from earlier in the bar */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commidi_1.naccim[commidi_1.midchan[all_1.iv + kv * 24 - 25]] =
0;
/* L45: */
}
}
}
/* Time from start of gulp to end of bar, used with forced beams */
tglp2 = (real) (all_1.lenb0 + all_1.ibar * all_1.lenb1);
if (all_1.lenb0 > 0) {
tglp2 -= all_1.lenb1;
}
*tglp1 = tglp2 - all_1.lenbar;
/* infbmx will only be true if in xtup that is NOT in explicit forced beam. */
i__2 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__2; ++all_1.iv) {
i__1 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__1; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
cwrest[commvl_1.ivx] = FALSE_;
infbmx[commvl_1.ivx - 1] = FALSE_;
inxtup[commvl_1.ivx - 1] = FALSE_;
if (all_1.ibar > 1) {
all_1.nn[commvl_1.ivx - 1] = all_1.nib[commvl_1.ivx +
all_1.ibar * 24 - 25] - all_1.nib[commvl_1.ivx + (
all_1.ibar - 1) * 24 - 25];
} else {
all_1.nn[commvl_1.ivx - 1] = all_1.nib[commvl_1.ivx +
all_1.ibar * 24 - 25];
}
/* L1: */
}
}
/* initialize list note counter, time(iv), curr. note(iv). The loop to 4 */
/* ONLY initializes each voice. */
in = 1;
nxtup = 0;
comarp_1.narp = 0;
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
comcwrf_1.cwrferm[commvl_1.ivx - 1] = FALSE_;
cnn[commvl_1.ivx - 1] = 1;
all_1.ivxo[in - 1] = commvl_1.ivx;
all_1.ipo[in - 1] = cnn[commvl_1.ivx - 1];
all_1.tnote[in - 1] = fnote_(all_1.nodur, &commvl_1.ivx, &c__1,
all_1.nacc);
all_1.to[in - 1] = 0.f;
xit[commvl_1.ivx - 1] = all_1.tnote[in - 1];
/* Note that xit(ivx) is to END of note in voice, but it1xtup is start time. */
if (all_1.nodur[commvl_1.ivx + all_1.ipo[in - 1] * 24 - 25] == 0)
{
/* First note of xtuplet at start of bar in voice ivx. */
++nxtup;
nxtnow[commvl_1.ivx - 1] = nxtup;
inxtup[commvl_1.ivx - 1] = TRUE_;
t1xtup[nxtup - 1] = 0.f;
/* Xtup at start of bar. If no explicit forced beam, start one, set */
/* signal infbmx, and save number ifbnow for use at termination. */
if (comfb_1.nfb[commvl_1.ivx - 1] > 0) {
i__3 = comfb_1.nfb[commvl_1.ivx - 1];
for (comfb_1.ifb = 1; comfb_1.ifb <= i__3; ++comfb_1.ifb)
{
if (comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb * 24 - 25]
> *tglp1 + xit[commvl_1.ivx - 1] +
comtol_1.tol) {
/* No explicit fb here; so exit loop and insert one. */
goto L61;
} else if (comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb *
24 - 25] < *tglp1 + xit[commvl_1.ivx - 1] +
comtol_1.tol && comfb_1.t2fb[commvl_1.ivx +
comfb_1.ifb * 24 - 25] > *tglp1 + xit[
commvl_1.ivx - 1] + comtol_1.tol) {
/* IS explicit fb here; must NOT insert one */
goto L62;
}
/* L60: */
}
}
L61:
/* If here, xtup isn't in explicit fb, so must insert one */
infbmx[commvl_1.ivx - 1] = TRUE_;
r__1 = t1xtup[nxtup - 1] + *tglp1;
addfb_(comfb_1.nfb, &commvl_1.ivx, &r__1, comfb_1.t1fb,
comfb_1.t2fb, comfb_1.ulfbq, &ifbadd, (ftnlen)1);
ifbnow[commvl_1.ivx - 1] = ifbadd;
}
L62:
if ((r__1 = xit[commvl_1.ivx - 1] - all_1.lenbar, dabs(r__1)) <
comtol_1.tol) {
xit[commvl_1.ivx - 1] = 1e3f;
}
++in;
/* L4: */
}
}
/* Build the list: This is a manual loop starting at 5 */
L5:
/* Determine which voice comes next from end of notes done so far. */
/* tmin is the earliest ending time of notes done so far */
tmin = 1e3f;
i__2 = all_1.nv;
for (iiv = 1; iiv <= i__2; ++iiv) {
i__1 = commvl_1.nvmx[iiv - 1];
for (kv = 1; kv <= i__1; ++kv) {
iivx = commvl_1.ivmx[iiv + kv * 24 - 25];
/* Computing MIN */
r__1 = tmin, r__2 = xit[iivx - 1];
tminn = dmin(r__1,r__2);
if (tminn < tmin - comtol_1.tol) {
tmin = tminn;
commvl_1.ivx = iivx;
}
/* L6: */
}
}
if ((r__1 = tmin - 1e3f, dabs(r__1)) < comtol_1.tol) {
goto L7;
}
all_1.ivxo[in - 1] = commvl_1.ivx;
++cnn[commvl_1.ivx - 1];
all_1.ipo[in - 1] = cnn[commvl_1.ivx - 1];
all_1.to[in - 1] = tmin;
/* Check if this voice is done */
all_1.tnote[in - 1] = fnote_(all_1.nodur, &commvl_1.ivx, &cnn[
commvl_1.ivx - 1], all_1.nacc);
if (cnn[commvl_1.ivx - 1] == all_1.nn[commvl_1.ivx - 1]) {
xit[commvl_1.ivx - 1] = 1e3f;
} else {
xit[commvl_1.ivx - 1] += all_1.tnote[in - 1];
}
/* Flag xtups */
if (all_1.nodur[commvl_1.ivx + cnn[commvl_1.ivx - 1] * 24 - 25] == 0) {
if (! inxtup[commvl_1.ivx - 1]) {
/* First note of xtup, not at start of bar. */
++nxtup;
nxtnow[commvl_1.ivx - 1] = nxtup;
inxtup[commvl_1.ivx - 1] = TRUE_;
t1xtup[nxtup - 1] = xit[commvl_1.ivx - 1] - all_1.tnote[in - 1];
/* (Note: can't be on last note in voice, so xit(ivx) <> 1000) */
/* Put xtuplet in a forced beam if not already in forced beam */
if (comfb_1.nfb[commvl_1.ivx - 1] > 0) {
i__1 = comfb_1.nfb[commvl_1.ivx - 1];
for (comfb_1.ifb = 1; comfb_1.ifb <= i__1; ++comfb_1.ifb) {
if (comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb * 24 - 25] > *
tglp1 + xit[commvl_1.ivx - 1] + comtol_1.tol) {
/* NO explicit bm; put one in */
goto L71;
} else if (comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb * 24 -
25] < *tglp1 + xit[commvl_1.ivx - 1] +
comtol_1.tol && comfb_1.t2fb[commvl_1.ivx +
comfb_1.ifb * 24 - 25] > *tglp1 + xit[
commvl_1.ivx - 1] + comtol_1.tol) {
/* IS explicit bm. Don't put one */
goto L72;
}
/* L70: */
}
}
L71:
/* If here, no explicit bm, so put one in */
infbmx[commvl_1.ivx - 1] = TRUE_;
r__1 = t1xtup[nxtup - 1] + *tglp1;
addfb_(comfb_1.nfb, &commvl_1.ivx, &r__1, comfb_1.t1fb,
comfb_1.t2fb, comfb_1.ulfbq, &ifbadd, (ftnlen)1);
ifbnow[commvl_1.ivx - 1] = ifbadd;
}
L72:
;
} else if (inxtup[commvl_1.ivx - 1]) {
/* This test is sufficient because already know nodur>0 */
inxtup[commvl_1.ivx - 1] = FALSE_;
if (infbmx[commvl_1.ivx - 1]) {
/* Xtup is in auto-forced beam, so end it */
comfb_1.t2fb[commvl_1.ivx + ifbnow[commvl_1.ivx - 1] * 24 - 25] =
t1xtup[nxtnow[commvl_1.ivx - 1] - 1] + all_1.nodur[
commvl_1.ivx + cnn[commvl_1.ivx - 1] * 24 - 25] + *tglp1;
infbmx[commvl_1.ivx - 1] = FALSE_;
}
}
if (bit_test(all_1.irest[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 - 25]
,24) || bit_test(all_1.irest[all_1.ivxo[in - 1] + all_1.ipo[in -
1] * 24 - 25],30)) {
/* For staff jumped beam, flag the first note (lowest voice) at same time. */
/* Later will start new notes group here. */
inj = in;
if (all_1.ivxo[in - 1] > 1) {
for (iin = in - 1; iin >= 1; --iin) {
if (all_1.to[iin - 1] + comtol_1.tol < all_1.to[in - 1]) {
goto L41;
}
if ((r__1 = all_1.to[iin - 1] - all_1.to[in - 1], dabs(r__1))
< comtol_1.tol) {
inj = iin;
goto L40;
}
L40:
;
}
}
L41:
all_1.irest[all_1.ivxo[inj - 1] + all_1.ipo[inj - 1] * 24 - 25] =
bit_set(all_1.irest[all_1.ivxo[inj - 1] + all_1.ipo[inj - 1] *
24 - 25],29);
}
++in;
goto L5;
L7:
comntot_1.ntot = in - 1;
i__1 = comntot_1.ntot - 1;
for (in = 1; in <= i__1; ++in) {
all_1.tno[in - 1] = all_1.to[in] - all_1.to[in - 1];
/* L8: */
}
all_1.tno[comntot_1.ntot - 1] = all_1.tnote[comntot_1.ntot - 1];
/* Debug writes */
/* write(*,'()') */
/* write(*,'(a)')' Greetings from PMXB' */
/* write(*,'(16i5)')(ivxo(in),in=1,ntot) */
/* write(*,'(16i5)')(ipo(in),in=1,ntot) */
/* write(*,'(16f5.1)')(to(in),in=1,ntot) */
/* write(*,'(16f5.1)')(tno(in),in=1,ntot) */
/* write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) */
/* write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) */
/* Done w/ list. Loop for parsing into note blocks: */
ib = 1;
istart[1] = 1;
comnsp_2.space[0] = 0.f;
in = 1;
/* A manual loop to set space(ib) and istop(ib) */
L9:
/* Computing MIN */
i__1 = in + 1;
commvl_1.ivx = all_1.ivxo[min(i__1,comntot_1.ntot) - 1];
/* Computing MIN */
i__1 = in + 1;
ip = all_1.ipo[min(i__1,comntot_1.ntot) - 1];
isl = all_1.islur[commvl_1.ivx + ip * 24 - 25];
if (in == comntot_1.ntot || (commvl_1.ivx == 1 && ((isl & 67109216) > 0 ||
bit_test(all_1.ipl[ip * 24 - 24],28) || bit_test(all_1.iornq[ip *
24],4)) || bit_test(isl,15)) || bit_test(all_1.irest[
commvl_1.ivx + ip * 24 - 25],29)) {
/* * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then */
/* Bits 1-13: stmgx+Tupf._) */
/* 14: Down fermata, was F */
/* 15: Trill w/o "tr", was U */
/* Checking for start of 2nd part of jumped beam */
/* Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; */
/* flow out of if-loop and into block-wrapup */
/* 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered */
/* voice, but it wasn't first in the list at the same time. So check if */
/* prior notes in list have same time */
/* 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef */
/* changes on last note in the list? */
if (bit_test(isl,15) && in < comntot_1.ntot) {
for (iin = in; iin >= 1; --iin) {
if (all_1.tno[iin - 1] > comtol_1.tol) {
in = iin;
all_1.islur[commvl_1.ivx + ip * 24 - 25] = bit_clear(
all_1.islur[commvl_1.ivx + ip * 24 - 25],15);
all_1.islur[all_1.ivxo[in] + all_1.ipo[in] * 24 - 25] =
bit_set(all_1.islur[all_1.ivxo[in] + all_1.ipo[in]
* 24 - 25],15);
goto L51;
}
/* L50: */
}
L51:
;
}
if (comnsp_2.space[ib - 1] < comtol_1.tol) {
comnsp_2.space[ib - 1] = all_1.tno[in - 1];
squez[ib] = 1.f;
}
istop[ib] = in;
} else if (comnsp_2.space[ib - 1] < comtol_1.tol) {
/* space hasn't been set yet, so tentatively set: */
comnsp_2.space[ib - 1] = all_1.tno[in - 1];
if (comnsp_2.space[ib - 1] < comtol_1.tol) {
++in;
} else {
squez[ib] = getsquez_(&in, &comntot_1.ntot, &comnsp_2.space[ib -
1], all_1.tnote, all_1.to);
istop[ib] = in;
}
goto L9;
} else if (all_1.tno[in] < comtol_1.tol) {
/* This is not the last note in the group, so */
++in;
goto L9;
} else if ((r__1 = all_1.tno[in] - comnsp_2.space[ib - 1], dabs(r__1)) <
comtol_1.tol) {
i__1 = in + 1;
xsquez = getsquez_(&i__1, &comntot_1.ntot, &comnsp_2.space[ib - 1],
all_1.tnote, all_1.to);
if ((r__1 = xsquez - squez[ib], dabs(r__1)) < comtol_1.tol) {
/* Keep spacing the same, update tentative stop point */
++in;
istop[ib] = in;
goto L9;
}
}
/* At this point istart and istop are good, so finalize block */
tstart[ib] = all_1.to[istart[ib] - 1];
if (istop[ib] == comntot_1.ntot) {
goto L15;
}
++ib;
istart[ib] = istop[ib - 1] + 1;
in = istart[ib];
/* Set tentative block space and squeeze-factor for upcoming block */
comnsp_2.space[ib - 1] = all_1.tno[in - 1];
if (comnsp_2.space[ib - 1] > comtol_1.tol) {
squez[ib] = getsquez_(&in, &comntot_1.ntot, &comnsp_2.space[ib - 1],
all_1.tnote, all_1.to);
}
istop[ib] = in;
goto L9;
L15:
comnsp_2.nb = ib;
/* Invert the list of places into ipl(0-7), making it easier to analyze a voice */
i__1 = comntot_1.ntot;
for (in = 1; in <= i__1; ++in) {
/* ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. */
/* ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) */
comipl2_1.ipl2[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 - 25] = in;
/* L13: */
}
/* Compute elemskips from start of bar to each note in the bar, for beam slopes */
eskzb = 0.f;
ib = 1;
i__1 = comntot_1.ntot;
for (in = 1; in <= i__1; ++in) {
if (in == istart[ib]) {
r__1 = comnsp_2.space[ib - 1] / squez[ib];
deskb = squez[ib] * feon_(&r__1);
} else if (all_1.tno[in - 2] > comtol_1.tol) {
eskzb += deskb;
}
all_1.eskz[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 - 25] = eskzb;
comeskz2_1.eskz2[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 - 25] =
eskzb;
if (in == istop[ib]) {
eskzb += deskb;
++ib;
}
/* L30: */
}
/* Debug writes */
/* print* */
/* write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) */
/* print*,'PMXB has now got blocks' */
/* write(*,'(16i5)')(istart(ib),ib=1,nb) */
/* write(*,'(16i5)')(istop(ib),ib=1,nb) */
/* write(*,'(16f5.1)')(space(ib),ib=1,nb) */
/* write(*,'(16f5.1)')(squez(ib),ib=1,nb) */
/* write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) */
/* c write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, */
/* * in=1,ntot) */
/* write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) */
/* Analyze for beams. */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
numbms[commvl_1.ivx] = 0;
mapfb[0] = 0;
mapfb[1] = 0;
mapfb[2] = 0;
mapfb[3] = 0;
/* First forced beams. */
if (comfb_1.nfb[commvl_1.ivx - 1] > 0) {
/* tglp2 is time from start of gulp to end of current bar. */
nfbbar = 0;
i__3 = comfb_1.nfb[commvl_1.ivx - 1];
for (comfb_1.ifb = 1; comfb_1.ifb <= i__3; ++comfb_1.ifb) {
if (comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb * 24 - 25] >
tglp2 - comtol_1.tol) {
goto L81;
}
++nfbbar;
++numbms[commvl_1.ivx];
numnew = numbms[commvl_1.ivx];
/* Times from beginning of bar */
itbb1 = (integer) (comfb_1.t1fb[commvl_1.ivx +
comfb_1.ifb * 24 - 25] - *tglp1 + comtol_1.tol);
itbb2 = (integer) (comfb_1.t2fb[commvl_1.ivx +
comfb_1.ifb * 24 - 25] - *tglp1 + comtol_1.tol);
i__4 = all_1.nn[commvl_1.ivx - 1];
for (ip = 1; ip <= i__4; ++ip) {
if ((integer) (all_1.to[comipl2_1.ipl2[commvl_1.ivx +
ip * 24 - 25] - 1] + comtol_1.tol) == itbb1) {
nip1fb = ip;
i__5 = all_1.nn[commvl_1.ivx - 1];
for (ip1 = ip; ip1 <= i__5; ++ip1) {
inip1 = comipl2_1.ipl2[commvl_1.ivx + ip1 *
24 - 25];
if ((r__1 = all_1.to[inip1 - 1] + all_1.tnote[
inip1 - 1] - itbb2, dabs(r__1)) <
comtol_1.tol) {
nip2fb = ip1;
itbb3 = itbb2 - 2;
goto L85;
}
/* L84: */
}
}
/* L83: */
}
s_wsle(&io___937);
e_wsle();
s_wsle(&io___938);
do_lio(&c__9, &c__1, "Timing problem w/ forced beams", (
ftnlen)30);
e_wsle();
s_wsfe(&io___939);
do_fio(&c__1, "Timing problem w/ forced beams", (ftnlen)
30);
e_wsfe();
L85:
logbeam_(&numnew, &nip1fb, &nip2fb);
/* Set up mapfb for forced beam just logged: */
ib1 = itbb1 / 2;
ib2 = itbb3 / 2;
ibrep = all_1.lenbar / *ibmrep / 2;
i__4 = *ibmrep;
for (irep = 1; irep <= i__4; ++irep) {
/* Computing MAX */
i__5 = 0, i__6 = ib1 - (irep - 1) * ibrep;
ib1now = max(i__5,i__6);
/* Computing MIN */
i__5 = irep * ibrep - 1, i__6 = ib2 - (irep - 1) *
ibrep;
ib2now = min(i__5,i__6);
mapnow = 0;
i__5 = ib2now;
for (ib = ib1now; ib <= i__5; ++ib) {
mapnow = bit_set(mapnow,ib);
/* L87: */
}
mapfb[irep - 1] |= mapnow;
/* L86: */
}
/* Since we are cycling thru forced beams, for those that start with a rest and */
/* have height & slope adjustments, move adjustments to next note. */
/* 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at */
/* start of beam */
if (bit_test(all_1.irest[commvl_1.ivx + nip1fb * 24 - 25],
0)) {
/* call setbits(ipl(ivx,nip1fb+1),6,11, */
/* * igetbits(ipl(ivx,nip1fb),6,11)) */
/* call setbits(ipl(ivx,nip1fb+1),6,17, */
/* * igetbits(ipl(ivx,nip1fb),6,17)) */
/* call setbits(islur(ivx,nip1fb+1),2,27, */
/* * igetbits(islur(ivx,nip1fb),2,27)) */
i__4 = nip2fb;
for (kp = nip1fb + 1; kp <= i__4; ++kp) {
i__5 = igetbits_(&all_1.ipl[commvl_1.ivx + nip1fb
* 24 - 25], &c__6, &c__11);
setbits_(&all_1.ipl[commvl_1.ivx + kp * 24 - 25],
&c__6, &c__11, &i__5);
i__5 = igetbits_(&all_1.ipl[commvl_1.ivx + nip1fb
* 24 - 25], &c__6, &c__17);
setbits_(&all_1.ipl[commvl_1.ivx + kp * 24 - 25],
&c__6, &c__17, &i__5);
i__5 = igetbits_(&all_1.islur[commvl_1.ivx +
nip1fb * 24 - 25], &c__2, &c__27);
setbits_(&all_1.islur[commvl_1.ivx + kp * 24 - 25]
, &c__2, &c__27, &i__5);
/* L88: */
}
}
/* L80: */
}
L81:
/* Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. */
/* Remember, makeabar is called 1/bar, and it calls findbeam once per voice. */
if (nfbbar > 0) {
comfb_1.nfb[commvl_1.ivx - 1] -= nfbbar;
i__3 = comfb_1.nfb[commvl_1.ivx - 1];
for (comfb_1.ifb = 1; comfb_1.ifb <= i__3; ++comfb_1.ifb)
{
comfb_1.t1fb[commvl_1.ivx + comfb_1.ifb * 24 - 25] =
comfb_1.t1fb[commvl_1.ivx + (comfb_1.ifb +
nfbbar) * 24 - 25];
comfb_1.t2fb[commvl_1.ivx + comfb_1.ifb * 24 - 25] =
comfb_1.t2fb[commvl_1.ivx + (comfb_1.ifb +
nfbbar) * 24 - 25];
*(unsigned char *)&comfb_1.ulfbq[commvl_1.ivx +
comfb_1.ifb * 24 - 25] = *(unsigned char *)&
comfb_1.ulfbq[commvl_1.ivx + (comfb_1.ifb +
nfbbar) * 24 - 25];
/* L82: */
}
}
}
comfb_1.ifb = 0;
/* Done with forced beam masks for this bar and voice. Now get normal beams. */
findbeam_(ibmrep, &numbms[1], mapfb);
/* L20: */
}
}
return 0;
} /* make1bar_ */
/* Subroutine */ int make2bar_(integer *ninow, real *tglp1, real *tstart,
logical *cwrest, real *squez, integer *istop, integer *numbms,
integer *istart, char *clefq, ftnlen clefq_len)
{
/* System generated locals */
address a__1[6], a__2[2], a__3[5], a__4[3], a__5[4], a__6[8], a__7[7];
integer i__1, i__2, i__3[6], i__4[2], i__5[5], i__6[3], i__7, i__8[4],
i__9, i__10[8], i__11, i__12, i__13[7];
real r__1, r__2;
logical L__1;
char ch__1[80], ch__2[82], ch__3[12], ch__4[1], ch__5[17], ch__6[16],
ch__7[11], ch__8[10], ch__9[44], ch__10[81], ch__11[113], ch__12[
3], ch__13[9], ch__14[129], ch__15[6], ch__16[5], ch__17[4],
ch__18[14], ch__19[22];
cilist ci__1;
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void), lbit_shift(integer, integer),
i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *,
char *, ftnlen), e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer pow_ii(integer *, integer *);
double r_lg10(real *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
extern logical isdotted_(integer *, integer *, integer *);
extern /* Subroutine */ int beamstrt_(char *, integer *, integer *,
integer *, real *, real *, integer *, ftnlen);
static real ptsavail;
extern /* Subroutine */ int dopsslur_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, logical *, integer *, char *, integer *, char *,
integer *, integer *, integer *, integer *, real *, integer *,
ftnlen, ftnlen), midievent_(char *, integer *, integer *, ftnlen);
static real stemshort;
static integer ib, ig, il, in, ip, kv;
extern /* Subroutine */ int adjusteskz_(integer *, real *, integer *,
integer *, real *);
static integer iib, icm, ing, len;
static real esk, xnd;
static integer ivf, iiv;
static real wgr, pts;
static logical secondgrace;
extern integer log2_(integer *);
extern /* Subroutine */ int chkkbdrests_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, real *, real *, integer *,
integer *, integer *, integer *, integer *);
static integer iacc, kacc, macc, ifig[2], icrd, ndig;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern doublereal feon_(real *);
static integer lcwr[24];
extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *,
integer *, integer *, integer *, integer *);
static char cwrq[79*24];
static real ptgr[37], spgr, ptsl, zero, tnow;
static integer nodu;
extern /* Subroutine */ int eskb4_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *), stop1_(
void), doacc_(integer *, integer *, char *, integer *, integer *,
integer *, integer *, logical *, ftnlen);
static logical isacc;
static integer nclef, iaskb[24];
static logical iscln, issig;
static integer nornb[24];
static logical isarp, isdot;
static integer lnote;
static char noteq[8];
static logical iscwr;
static char soutq[80];
static integer lsout, itrpt, itsig;
extern integer ncmid_(integer *, integer *);
static integer iirpt, lclow;
extern /* Subroutine */ int dodyn_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
logical *, integer *, integer *, char *, integer *, logical *,
char *, integer *, ftnlen, ftnlen), docrd_(integer *, integer *,
integer *, integer *, integer *, real *, char *, integer *, char *
, integer *, integer *, integer *, integer *, logical *, integer *
, integer *, integer *, real *, logical *, integer *, ftnlen,
ftnlen), putcb_(integer *, integer *, char *, integer *, ftnlen),
beamn1_(char *, integer *, ftnlen), notex_(char *, integer *,
ftnlen);
static logical iscacc;
extern /* Subroutine */ int addask_(real *, real *, real *, real *, real *
, real *, logical *);
static logical isclef, isflag, isaccs, bspend, isgaft;
static real ptclef[24];
static integer ihornb[576] /* was [24][24] */;
static real eskndg[24], ptsndg[24];
static logical rpndot;
static char notexq[79];
static logical stemup, beamon1[24];
static integer ibmcnt1[24], lnoten;
extern /* Subroutine */ int wsclef_(integer *, integer *, char *, integer
*, ftnlen);
static real eonsqz;
extern /* Subroutine */ int precrd_(integer *, integer *, integer *,
integer *, integer *, integer *, char *, logical *, integer *,
ftnlen), chkarp_(integer *, integer *, integer *, integer *,
logical *, logical *);
static integer ibmchk;
static real taccfac, esksav, ptsadd;
static integer ihshft;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer lchead;
extern integer lenstr_(char *, integer *, ftnlen);
static integer islhgt;
static real offnsk;
extern /* Subroutine */ int putfig_(integer *, integer *, real *, logical
*, char *, integer *, ftnlen), putarp_(real *, integer *, integer
*, integer *, integer *, char *, integer *, ftnlen), doslur_(
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, logical *, integer *, char *,
integer *, char *, integer *, integer *, integer *, integer *,
real *, integer *, ftnlen, ftnlen);
static integer iphold;
extern /* Subroutine */ int dograce_(integer *, integer *, real *, char *,
integer *, integer *, integer *, integer *, integer *, logical *,
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, real *, char *, integer *, ftnlen, ftnlen), notefq_(
char *, integer *, integer *, integer *, ftnlen), addmidi_(
integer *, integer *, integer *, integer *, real *, logical *,
logical *), putorn_(integer *, integer *, integer *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, real *, char *, integer *,
integer *, integer *, logical *, logical *, ftnlen, ftnlen),
dotmov_(real *, real *, char *, integer *, integer *, ftnlen),
beamend_(char *, integer *, ftnlen), beamid_(char *, integer *,
ftnlen);
static logical isgrace;
static integer icashft;
static real ptbneed;
static integer itleft, itendb;
extern integer iashft_(integer *);
static real ptsneed;
extern /* Subroutine */ int clefsym_(integer *, char *, integer *,
integer *, ftnlen);
static logical isrshft, isfirst, nofirst;
extern /* Subroutine */ int endslur_(logical *, logical *, integer *,
integer *, integer *, integer *, integer *, char *, integer *,
logical *, ftnlen);
static char slurudq[1];
extern /* Subroutine */ int putshft_(integer *, logical *, char *,
integer *, ftnlen), setbits_(integer *, integer *, integer *,
integer *);
static integer itright, nolevc, ivlast;
extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
;
static integer mtrspc;
static real wheadpt1;
/* Fortran I/O blocks */
static icilist io___959 = { 0, noteq, 0, "(1H{,i3,1H})", 5, 1 };
static icilist io___961 = { 0, noteq, 0, "(1H{,i2,1H})", 4, 1 };
static icilist io___962 = { 0, noteq, 0, "(i1)", 1, 1 };
static cilist io___965 = { 0, 11, 0, "(a)", 0 };
static cilist io___966 = { 0, 11, 0, "(a)", 0 };
static cilist io___969 = { 0, 11, 0, "(a)", 0 };
static icilist io___972 = { 0, soutq+8, 0, "(f4.1)", 4, 1 };
static icilist io___973 = { 0, soutq+8, 0, "(f4.2)", 4, 1 };
static icilist io___974 = { 0, soutq+10, 0, "(i2)", 2, 1 };
static icilist io___975 = { 0, soutq+11, 0, "(i1)", 1, 1 };
static cilist io___980 = { 0, 6, 0, 0, 0 };
static cilist io___981 = { 0, 6, 0, 0, 0 };
static cilist io___1001 = { 0, 6, 0, 0, 0 };
static cilist io___1017 = { 0, 11, 0, "(a)", 0 };
static cilist io___1018 = { 0, 11, 0, "(a)", 0 };
static cilist io___1019 = { 0, 11, 0, "(a)", 0 };
static cilist io___1020 = { 0, 11, 0, "(a)", 0 };
static cilist io___1021 = { 0, 11, 0, "(a)", 0 };
static cilist io___1022 = { 0, 6, 0, 0, 0 };
static cilist io___1023 = { 0, 11, 0, "(a)", 0 };
static cilist io___1024 = { 0, 11, 0, "(a)", 0 };
static cilist io___1025 = { 0, 11, 0, "(a)", 0 };
static icilist io___1029 = { 0, notexq+11, 0, "(i2)", 2, 1 };
static icilist io___1035 = { 0, notexq+6, 0, "(f3.1)", 3, 1 };
static icilist io___1036 = { 0, notexq+6, 0, "(f4.1)", 4, 1 };
static icilist io___1038 = { 0, notexq+5, 0, "(f3.1)", 3, 1 };
static icilist io___1039 = { 0, notexq+5, 0, "(f4.1)", 4, 1 };
static cilist io___1041 = { 0, 6, 0, 0, 0 };
static cilist io___1042 = { 0, 11, 0, "(a)", 0 };
static cilist io___1043 = { 0, 11, 0, "(a)", 0 };
static icilist io___1050 = { 0, notexq, 0, "(f4.2)", 79, 1 };
static cilist io___1053 = { 0, 6, 0, 0, 0 };
static cilist io___1066 = { 0, 11, 0, "(a)", 0 };
static cilist io___1069 = { 0, 11, 0, "(a)", 0 };
static cilist io___1072 = { 0, 11, 0, "(a)", 0 };
static cilist io___1074 = { 0, 11, 0, "(a)", 0 };
/* Factors for grace note, clef spacing. (fraction of wheadpt) */
/* In 1.04, moved to block data subprogram */
/* 130316 */
/* Set up main ib loop within which a block (notes group) is written */
/* Parameter adjustments */
--clefq;
--istart;
--numbms;
--istop;
--squez;
--cwrest;
--tstart;
/* Function Body */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
all_1.ibmcnt[commvl_1.ivx - 1] = 1;
ibmcnt1[commvl_1.ivx - 1] = 1;
all_1.beamon[commvl_1.ivx - 1] = FALSE_;
beamon1[commvl_1.ivx - 1] = FALSE_;
nornb[commvl_1.ivx - 1] = 0;
iaskb[commvl_1.ivx - 1] = 1;
comxtup_1.vxtup[commvl_1.ivx - 1] = FALSE_;
comdraw_1.drawbm[commvl_1.ivx - 1] = TRUE_;
/* L25: */
}
}
comas1_1.naskb = 0;
ifig[0] = 1;
ifig[1] = 1;
comxtup_1.ixtup = 0;
bspend = FALSE_;
iscwr = FALSE_;
rpndot = FALSE_;
i__2 = comnsp_2.nb;
for (ib = 1; ib <= i__2; ++ib) {
/* Check for segno */
if (bit_test(all_1.iornq[all_1.ipo[istart[ib] - 1] * 24],4) &&
all_1.ivxo[istart[ib] - 1] == 1) {
if (comgrace_1.noffseg <= -10) {
s_wsfi(&io___959);
do_fio(&c__1, (char *)&comgrace_1.noffseg, (ftnlen)sizeof(
integer));
e_wsfi();
lnoten = 5;
} else if (comgrace_1.noffseg < 0 || comgrace_1.noffseg >= 10) {
s_wsfi(&io___961);
do_fio(&c__1, (char *)&comgrace_1.noffseg, (ftnlen)sizeof(
integer));
e_wsfi();
lnoten = 4;
} else {
s_wsfi(&io___962);
do_fio(&c__1, (char *)&comgrace_1.noffseg, (ftnlen)sizeof(
integer));
e_wsfi();
lnoten = 1;
}
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 6, a__1[1] = "znotes";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 6, a__1[3] = "segnoo";
i__3[4] = lnoten, a__1[4] = noteq;
i__3[5] = 1, a__1[5] = "9";
s_cat(notexq, a__1, i__3, &c__6, (ftnlen)79);
lnote = lnoten + 15;
i__1 = all_1.nv;
for (all_1.iv = 2; all_1.iv <= i__1; ++all_1.iv) {
if (lnote > 60) {
if (comlast_1.islast) {
s_wsfe(&io___965);
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "%";
s_cat(ch__1, a__2, i__4, &c__2, (ftnlen)80);
do_fio(&c__1, ch__1, lnote + 1);
e_wsfe();
}
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sepsymq + (all_1.iv - 2);
i__5[1] = 1, a__3[1] = all_1.sq;
i__5[2] = 6, a__3[2] = "segnoo";
i__5[3] = lnoten, a__3[3] = noteq;
i__5[4] = 1, a__3[4] = "9";
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
lnote = lnoten + 9;
} else {
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = all_1.sepsymq + (all_1.iv - 2);
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 6, a__1[3] = "segnoo";
i__3[4] = lnoten, a__1[4] = noteq;
i__3[5] = 1, a__1[5] = "9";
s_cat(notexq, a__1, i__3, &c__6, (ftnlen)79);
lnote = lnote + lnoten + 9;
}
/* L130: */
}
if (comlast_1.islast) {
s_wsfe(&io___966);
/* Writing concatenation */
i__6[0] = lnote, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = all_1.sq;
i__6[2] = 2, a__4[2] = "en";
s_cat(ch__2, a__4, i__6, &c__3, (ftnlen)82);
do_fio(&c__1, ch__2, lnote + 3);
e_wsfe();
}
lnote = 0;
}
/* Check for new clefs */
isclef = FALSE_;
if (bit_test(all_1.islur[all_1.ivxo[istart[ib] - 1] + all_1.ipo[
istart[ib] - 1] * 24 - 25],15)) {
/* In preceding line, fl32 gave wrong result for ... .gt.0 !!! */
i__1 = istop[ib];
for (in = istart[ib]; in <= i__1; ++in) {
if (bit_test(all_1.islur[all_1.ivxo[in - 1] + all_1.ipo[in -
1] * 24 - 25],11)) {
i__7 = lbit_shift(all_1.islur[all_1.ivxo[in - 1] +
all_1.ipo[in - 1] * 24 - 25], (ftnlen)-12) & 7;
wsclef_(&all_1.ivxo[in - 1], ninow, clefq + 1, &i__7, (
ftnlen)1);
}
/* L140: */
}
if (comlast_1.islast) {
s_wsfe(&io___969);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 11, a__2[1] = "pmxnewclefs";
s_cat(ch__3, a__2, i__4, &c__2, (ftnlen)12);
do_fio(&c__1, ch__3, (ftnlen)12);
e_wsfe();
}
isclef = TRUE_;
}
/* Start a notes group. We're just gonna define every one using pnotes{n}, */
/* where \def\pnotes#1{\vnotes#1\elemskip} */
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 7, a__2[1] = "pnotes{";
s_cat(soutq, a__2, i__4, &c__2, (ftnlen)80);
r__1 = comnsp_2.space[ib - 1] / squez[ib];
eonsqz = squez[ib] * feon_(&r__1);
if (eonsqz > 9.995f) {
s_wsfi(&io___972);
do_fio(&c__1, (char *)&eonsqz, (ftnlen)sizeof(real));
e_wsfi();
} else if (eonsqz > .995f) {
s_wsfi(&io___973);
do_fio(&c__1, (char *)&eonsqz, (ftnlen)sizeof(real));
e_wsfi();
} else if (eonsqz > .095f) {
/* Writing concatenation */
i__4[0] = 8, a__2[0] = soutq;
i__4[1] = 2, a__2[1] = "0.";
s_cat(soutq, a__2, i__4, &c__2, (ftnlen)80);
s_wsfi(&io___974);
r__1 = eonsqz * 100;
i__1 = i_nint(&r__1);
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfi();
} else {
/* Writing concatenation */
i__4[0] = 8, a__2[0] = soutq;
i__4[1] = 3, a__2[1] = "0.0";
s_cat(soutq, a__2, i__4, &c__2, (ftnlen)80);
s_wsfi(&io___975);
r__1 = eonsqz * 100;
i__1 = i_nint(&r__1);
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfi();
}
/* Writing concatenation */
i__4[0] = 12, a__2[0] = soutq;
i__4[1] = 1, a__2[1] = "}";
s_cat(soutq, a__2, i__4, &c__2, (ftnlen)80);
lsout = 13;
/* Check whole block, flag accidentals etc that are too close, one per *time*. */
/* Note about bar starts and after rpt's/boublebars: There is an afterruleskip */
/* (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so */
/* (dotsfac*wheadpt) is presumed to be filled up. */
in = istart[ib] - 1;
itrpt = -1;
itsig = -1;
/* Begin big manual loop over notes in this block; ends at 112 */
L111:
++in;
if (in > istop[ib]) {
goto L112;
}
ip = all_1.ipo[in - 1];
commvl_1.ivx = all_1.ivxo[in - 1];
if (commvl_1.ivx <= all_1.nv) {
all_1.iv = commvl_1.ivx;
} else {
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
if (commvl_1.nvmx[all_1.iv - 1] == 2 && commvl_1.ivmx[
all_1.iv + 23] == commvl_1.ivx) {
goto L129;
}
/* L128: */
}
s_wsle(&io___980);
do_lio(&c__9, &c__1, "Trouble finding iv!, ivx,nvmx,ivmx:", (
ftnlen)35);
do_lio(&c__3, &c__1, (char *)&commvl_1.ivx, (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&commvl_1.nvmx[0], (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&commvl_1.nvmx[1], (ftnlen)sizeof(
integer));
e_wsle();
s_wsle(&io___981);
do_lio(&c__3, &c__1, (char *)&commvl_1.ivmx[0], (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&commvl_1.ivmx[24], (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&commvl_1.ivmx[1], (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&commvl_1.ivmx[25], (ftnlen)sizeof(
integer));
e_wsle();
s_stop("", (ftnlen)0);
}
L129:
/* Call precrd here so we know how much space to add for accid's in chords */
/* After calling precrd, icashft>0 means there is a shifted chordal accid (incl. */
/* main note. */
/* To call precrd, need up-downness, so must track if in beam. */
/* Deal w/ staff-jumping beams later */
/* if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) */
/* * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. */
/* * btest(nacc(ivx,ip),21)) then */
/* if (.not.btest(irest(ivx,ip),24)) then */
if (numbms[commvl_1.ivx] > 0 && ibmcnt1[commvl_1.ivx - 1] <= numbms[
commvl_1.ivx] && all_1.ibm1[commvl_1.ivx + ibmcnt1[
commvl_1.ivx - 1] * 24 - 25] == ip) {
beamon1[commvl_1.ivx - 1] = TRUE_;
}
icashft = 0;
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. */
if (beamon1[commvl_1.ivx - 1]) {
precrd_(&commvl_1.ivx, &ip, &all_1.nolev[commvl_1.ivx + ip *
24 - 25], &all_1.nacc[commvl_1.ivx + ip * 24 - 25], &
all_1.ipl[commvl_1.ivx + ip * 24 - 25], &all_1.irest[
commvl_1.ivx + ip * 24 - 25], all_1.ulq + (
commvl_1.ivx + ibmcnt1[commvl_1.ivx - 1] * 24 - 25), &
c_false, &icashft, (ftnlen)1);
} else {
i__1 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[commvl_1.ivx + ip * 24 -
25], &i__1, &all_1.islur[commvl_1.ivx + ip * 24 - 25],
&commvl_1.nvmx[all_1.iv - 1], &commvl_1.ivx, &
all_1.nv);
precrd_(&commvl_1.ivx, &ip, &all_1.nolev[commvl_1.ivx + ip *
24 - 25], &all_1.nacc[commvl_1.ivx + ip * 24 - 25], &
all_1.ipl[commvl_1.ivx + ip * 24 - 25], &all_1.irest[
commvl_1.ivx + ip * 24 - 25], ch__4, &c_false, &
icashft, (ftnlen)1);
}
}
/* Turn beam off? */
if (beamon1[commvl_1.ivx - 1] && all_1.ibm2[commvl_1.ivx + ibmcnt1[
commvl_1.ivx - 1] * 24 - 25] == ip) {
beamon1[commvl_1.ivx - 1] = FALSE_;
++ibmcnt1[commvl_1.ivx - 1];
}
/* Remember, rpts & internal sigs can only come at start of (internal) block */
isacc = (all_1.nacc[commvl_1.ivx + ip * 24 - 25] & 3) > 0 && !
bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],17) && !
bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10);
/* i.e., do not set for chord. Now check for "(" as ornament on main note, */
/* !!! Need to do this for chord notes too. Maybe in chkarp? */
isaccs = isacc || bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],0);
/* 5/15/02 Add check for ) ornament of prior note. */
/* 5/16 Nope...fails when grace intervenes. */
/* if (ip .gt. 1) then */
/* isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) */
/* end if */
isarp = bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],27);
iscacc = FALSE_;
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* There is a chord here; check for arpeggios and accidentals. Note accid shifts are */
/* not of concern here, only whether there's an accid, whick causes iscacc=.true. */
iscacc = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - 25], &
c__3, &c__0) > 0 && ! bit_test(all_1.nacc[commvl_1.ivx +
ip * 24 - 25],17);
chkarp_(&comtrill_1.ncrd, comtrill_1.icrdat, &commvl_1.ivx, &ip, &
iscacc, &isarp);
}
/* When we get motivated, will do spacing for arpeggios here. */
if (commvl_1.ivx == 1 && (all_1.islur[commvl_1.ivx + ip * 24 - 25] &
96) > 0) {
itrpt = i_nint(&all_1.to[in - 1]);
}
issig = bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],28);
if (commvl_1.ivx == 1 && issig) {
itsig = i_nint(&all_1.to[in - 1]);
}
isgrace = bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],4) && !
bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],29) && !
bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],31);
isgaft = FALSE_;
if (ip > 1) {
xnd = all_1.tnote[comipl2_1.ipl2[commvl_1.ivx + (ip - 1) * 24 -
25] - 1];
isgaft = bit_test(all_1.ipl[commvl_1.ivx + (ip - 1) * 24 - 25],29)
|| bit_test(all_1.ipl[commvl_1.ivx + (ip - 1) * 24 - 25],
31);
isgrace = isgrace || isgaft;
}
iscln = isclef && bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],
11);
/* Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd */
isflag = ip > 1 && xnd > comtol_1.tol && xnd < 16.f - comtol_1.tol;
if (isflag) {
i__7 = ip - 1;
i__1 = ncmid_(&all_1.iv, &i__7);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[commvl_1.ivx + (ip - 1) * 24
- 25], &i__1, &all_1.islur[commvl_1.ivx + (ip - 1) * 24 -
25], &commvl_1.nvmx[all_1.iv - 1], &commvl_1.ivx, &
all_1.nv);
isflag = ! bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25]
,0) && *(unsigned char *)&ch__4[0] == 'u';
}
if (isflag) {
i__1 = numbms[commvl_1.ivx];
for (ibmchk = 1; ibmchk <= i__1; ++ibmchk) {
if (ip - 1 < all_1.ibm1[commvl_1.ivx + ibmchk * 24 - 25]) {
goto L117;
/* Add check for non-beamed xtuplets. May be problem with stem direction. */
/* else if (ip-1.le.ibm2(ivx,ibmchk)) then */
} else if (ip - 1 <= all_1.ibm2[commvl_1.ivx + ibmchk * 24 -
25] && ! bit_test(all_1.islur[commvl_1.ivx +
all_1.ibm1[commvl_1.ivx + ibmchk * 24 - 25] * 24 - 25]
,18)) {
isflag = FALSE_;
goto L117;
}
/* L116: */
}
}
L117:
/* If isflag, then won't need to check for dot on prev. note. */
/* 5/16/02 ??? Try using this for ) ornament. */
isflag = isflag || bit_test(all_1.iornq[commvl_1.ivx + (ip - 1) * 24
- 1],13);
isdot = ip > 1;
if (isdot) {
i__1 = ip - 1;
isdot = isdotted_(all_1.nodur, &commvl_1.ivx, &i__1);
}
isrshft = ip > 1;
if (isrshft) {
isrshft = bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25],
20);
}
if (! (isaccs || isgrace || iscln || isflag || isrshft || isdot ||
bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],26) ||
bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],21) ||
isarp || bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],27)
|| iscacc)) {
goto L111;
}
/* Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. */
/* Compute pts, the total occupied space including prior notehead. */
/* 130324 */
/* wheadpt1 = wheadpt*fullsize(iv) */
wheadpt1 = comask_1.wheadpt * comfig_1.fullsize[cominsttrans_1.instno[
all_1.iv - 1] - 1];
pts = wheadpt1;
/* Set up for possible cautionary accidental here */
if (isaccs || iscacc) {
if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],31)) {
taccfac = spfacs_1.accfac;
} else {
taccfac = spfacs_1.accfac * 1.4f;
/* cautionary accidental */
}
}
if (isgrace) {
secondgrace = FALSE_;
i__1 = comgrace_1.ngrace;
for (ig = 1; ig <= i__1; ++ig) {
if (! isgaft) {
if (comgrace_1.ipg[ig - 1] == ip && comgrace_1.ivg[ig - 1]
== commvl_1.ivx) {
goto L123;
}
} else if (ip > 1) {
if (comgrace_1.ipg[ig - 1] == ip - 1 && comgrace_1.ivg[ig
- 1] == commvl_1.ivx) {
goto L123;
}
}
/* L122: */
}
s_wsle(&io___1001);
do_lio(&c__9, &c__1, "Problem finding grace index in makeabar", (
ftnlen)39);
e_wsle();
s_stop("", (ftnlen)0);
L123:
/* wgr = distance to backspace (in headwidths), less main acc. */
/* ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. */
/* spgr = total space needed (w/o main acc). */
/* Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. */
if (comgrace_1.nng[ig - 1] == 1) {
wgr = spfacs_1.grafac;
if (comgrace_1.multg[ig - 1] == 0) {
wgr += -.4f;
}
} else {
wgr = comgrace_1.nng[ig - 1] * spfacs_1.emgfac;
i__1 = comgrace_1.nng[ig - 1];
for (ing = 2; ing <= i__1; ++ing) {
if (comgrace_1.naccg[comgrace_1.ngstrt[ig - 1] - 1 + ing
- 1] > 0) {
wgr += spfacs_1.acgfac;
}
/* L126: */
}
}
if (comgrace_1.graspace[ig - 1] > 0.f) {
/* User-defined space before grace */
wgr += comgrace_1.graspace[ig - 1];
}
ptgr[ig - 1] = wgr * wheadpt1;
spgr = ptgr[ig - 1] + spfacs_1.xb4fac * wheadpt1;
/* !!! May need to mod for chord accid's */
if (isaccs || iscacc) {
ptgr[ig - 1] += taccfac * wheadpt1;
}
if (comgrace_1.naccg[comgrace_1.ngstrt[ig - 1] - 1] > 0) {
spgr += wheadpt1 * spfacs_1.agc1fac;
}
pts += spgr;
/* Special check for after-grace on ip-1 and normal on ip. Must go back thru */
/* loop again for the normal grace. */
if (isgaft && ig < comgrace_1.ngrace && ! secondgrace) {
if (comgrace_1.ipg[ig] == ip) {
secondgrace = TRUE_;
++ig;
goto L123;
}
}
}
if (iscln) {
pts += spfacs_1.clefac * wheadpt1;
/* How far to backspace when printing the clef */
ptclef[commvl_1.ivx - 1] = 0.f;
/* !!! May need to mod for chord accid's */
if (isaccs || iscacc) {
ptclef[commvl_1.ivx - 1] += taccfac * wheadpt1;
}
if (isgrace) {
ptclef[commvl_1.ivx - 1] += spgr;
}
}
if (isrshft) {
pts += spfacs_1.rtshfac * wheadpt1;
} else if (isflag) {
pts += spfacs_1.flagfac * wheadpt1;
} else if (isdot) {
pts += spfacs_1.dotfac * wheadpt1;
}
if ((r__1 = all_1.to[in - 1] - itrpt, dabs(r__1)) < comtol_1.tol) {
/* Repeat, need a little extra space */
pts += spfacs_1.dotsfac * wheadpt1;
}
if (isarp) {
pts += spfacs_1.arpfac * wheadpt1;
}
/* Add in padding space */
pts += spfacs_1.xspfac * wheadpt1;
/* Now done with all items needing space except accidentals, */
/* accidental shifts, and left-notehead-shifts, and will later */
/* subtract a notehead if at start of bar. */
/* Get available space in elemskips (esk) */
/* isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. */
/* * to(in) .eq. itsig */
isfirst = ip == 1 || (r__1 = all_1.to[in - 1] - itrpt, dabs(r__1)) <
comtol_1.tol || (r__2 = all_1.to[in - 1] - itsig, dabs(r__2))
< comtol_1.tol;
if (isfirst) {
/* At start of bar or after repeat sign or new signature */
/* if (to(in) .eq. itsig) then */
if ((r__1 = all_1.to[in - 1] - itsig, dabs(r__1)) < comtol_1.tol)
{
esk = 0.f;
} else {
esk = comask_1.fbar;
}
} else {
/* Not 1st note of bar */
esk = all_1.eskz[commvl_1.ivx + ip * 24 - 25] - all_1.eskz[
commvl_1.ivx + (ip - 1) * 24 - 25];
}
if (isgrace) {
/* Since graces can be very long, cannot assume no interference if prior */
/* note uses >1 noteskip. So must get elsk's back to prior note, whether or */
/* not it used only one noteskip. */
/* <>???? */
/* 10/8/05 Kluge to not zero out esk if in xtup */
esksav = esk;
/* Computing MAX */
i__1 = 1, i__7 = ip - 2;
if ((ip <= 2 || all_1.nodur[commvl_1.ivx + max(i__1,i__7) * 24 -
25] > 0) && (r__1 = all_1.to[in - 1] - itsig, dabs(r__1))
> comtol_1.tol) {
eskb4_(&ip, &commvl_1.ivx, &in, &ib, comnsp_2.space, &tstart[
1], &comask_1.fbar, &itrpt, &esk);
}
/* * to(in).ne.itsig) */
if (dabs(esk) < comtol_1.tol) {
esk = esksav;
}
}
/* Done getting available elemskips. Remove headwidth if first. Must do here */
/* rather than earlier since check uses isfirst */
if (isfirst) {
pts -= wheadpt1;
}
/* Deal with accidental shifts and left-notehead shifts */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* In a chord */
ptsl = 0.f;
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],27)) {
ptsl = wheadpt1;
}
/* Computing MAX */
r__1 = ptsl, r__2 = icashft * .05f * wheadpt1;
ptsadd = dmax(r__1,r__2);
/* Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK */
} else {
/* Not in a chord */
ihshft = 0;
if (isaccs) {
ihshft = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - 25], &
c__7, &c__10);
/* if (ihshft .ne. 0) ihshft = max(0,64-ihshft) */
if (ihshft != 0) {
/* Computing MAX */
i__1 = 0, i__7 = 107 - ihshft;
ihshft = max(i__1,i__7);
}
}
/* Check for left-shifted main note */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],8)) {
ihshft = max(20,ihshft);
}
ptsadd = ihshft * .05f * wheadpt1;
}
pts += ptsadd;
if (isgrace) {
ptgr[ig - 1] += ptsadd;
}
if (iscln) {
ptclef[commvl_1.ivx - 1] += ptsadd;
}
/* Left-shifted, non-chord note before? */
if (ip > 1) {
if (! bit_test(all_1.ipl[commvl_1.ivx + (ip - 1) * 24 - 25],10) &&
bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25],
27)) {
pts -= wheadpt1;
}
}
/* Try big accidentals first */
ptbneed = pts;
if (isaccs || iscacc) {
ptbneed += wheadpt1 * spfacs_1.bacfac;
}
if (comask_1.poenom * esk > ptbneed) {
/* Set flag for big accidental */
if (isacc) {
all_1.nacc[commvl_1.ivx + ip * 24 - 25] = bit_set(all_1.nacc[
commvl_1.ivx + ip * 24 - 25],3);
}
goto L99;
}
/* Cannot use big, so try small */
ptsneed = pts;
if (isaccs || iscacc) {
ptsneed += taccfac * wheadpt1;
}
if (comask_1.poenom * esk < ptsneed) {
addask_(&all_1.to[in - 1], &ptsneed, &esk, &comask_1.fixednew, &
comask_1.scaldold, &c_b762, &c_false);
}
L99:
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],26)) {
/* User-defined space. Warning, "zero" may change value in addask! */
zero = 0.f;
addask_(&all_1.to[in - 1], &ptsneed, &zero, &comask_1.fixednew, &
comask_1.scaldold, tglp1, &c_true);
}
/* End of big manual loop over "in" for accidental checking */
goto L111;
L112:
/* End of ask analysis for this block. */
/* Adjust eskz if there are added spaces. Corrects length of xtup brackets. */
if (comas1_1.naskb > 0) {
adjusteskz_(&ib, &squez[1], &istart[1], &istop[1], &
comask_1.poenom);
}
/* Check for internal repeat or sig change. */
if (ib > 1 && all_1.ivxo[istart[ib] - 1] == 1) {
iirpt = all_1.islur[all_1.ipo[istart[ib] - 1] * 24 - 24] &
67109216;
if (iirpt > 0) {
/* Internal repeat */
if (comlast_1.islast) {
s_wsfe(&io___1017);
/* Writing concatenation */
i__8[0] = 1, a__5[0] = all_1.sq;
i__8[1] = 7, a__5[1] = "advance";
i__8[2] = 1, a__5[2] = all_1.sq;
i__8[3] = 8, a__5[3] = "barno-1%";
s_cat(ch__5, a__5, i__8, &c__4, (ftnlen)17);
do_fio(&c__1, ch__5, (ftnlen)17);
e_wsfe();
}
if (iirpt == 96) {
if (comlast_1.islast) {
s_wsfe(&io___1018);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 15, a__2[1] = "leftrightrepeat";
s_cat(ch__6, a__2, i__4, &c__2, (ftnlen)16);
do_fio(&c__1, ch__6, (ftnlen)16);
e_wsfe();
}
comask_1.fixednew += spfacs_1.lrrptfac * comask_1.wheadpt;
} else if (bit_test(iirpt,5)) {
if (comlast_1.islast) {
s_wsfe(&io___1019);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 10, a__2[1] = "leftrepeat";
s_cat(ch__7, a__2, i__4, &c__2, (ftnlen)11);
do_fio(&c__1, ch__7, (ftnlen)11);
e_wsfe();
}
comask_1.fixednew += spfacs_1.rptfac * comask_1.wheadpt;
} else if (bit_test(iirpt,6)) {
if (comlast_1.islast) {
s_wsfe(&io___1020);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 11, a__2[1] = "rightrepeat";
s_cat(ch__3, a__2, i__4, &c__2, (ftnlen)12);
do_fio(&c__1, ch__3, (ftnlen)12);
e_wsfe();
}
comask_1.fixednew += spfacs_1.rptfac * comask_1.wheadpt;
} else if (bit_test(iirpt,8)) {
if (comlast_1.islast) {
s_wsfe(&io___1021);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 9, a__2[1] = "doublebar";
s_cat(ch__8, a__2, i__4, &c__2, (ftnlen)10);
do_fio(&c__1, ch__8, (ftnlen)10);
e_wsfe();
}
} else {
s_wsle(&io___1022);
do_lio(&c__9, &c__1, "Unexpected mid-bar repeat command "
"R*", (ftnlen)36);
e_wsle();
stop1_();
}
comask_1.scaldold -= comask_1.fbar;
}
if (bit_test(all_1.ipl[all_1.ipo[istart[ib] - 1] * 24 - 24],28)) {
/* Internal signature change. */
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 17, a__2[1] = "generalsignature{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 18;
if (comtop_1.isig < 0) {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "-";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
++lnote;
}
if (comlast_1.islast) {
s_wsfe(&io___1023);
/* Writing concatenation */
i__6[0] = lnote, a__4[0] = notexq;
i__1 = abs(comtop_1.isig) + 48;
chax_(ch__4, (ftnlen)1, &i__1);
i__6[1] = 1, a__4[1] = ch__4;
i__6[2] = 2, a__4[2] = "}%";
s_cat(ch__2, a__4, i__6, &c__3, (ftnlen)82);
do_fio(&c__1, ch__2, lnote + 3);
e_wsfe();
}
if (comlast_1.islast && comignorenats_1.ignorenats) {
s_wsfe(&io___1024);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 11, a__2[1] = "ignorenats%";
s_cat(ch__3, a__2, i__4, &c__2, (ftnlen)12);
do_fio(&c__1, ch__3, (ftnlen)12);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1025);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 14, a__1[1] = "zchangecontext";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 12, a__1[3] = "addspace{-.5";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 15, a__1[5] = "afterruleskip}%";
s_cat(ch__9, a__1, i__3, &c__6, (ftnlen)44);
do_fio(&c__1, ch__9, (ftnlen)44);
e_wsfe();
}
lnote = 0;
}
}
comnsp_2.flgndb = FALSE_;
/* Done with start-of-block stuff. Begin main loop over voices. */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
i__7 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__7; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
icm = commidi_1.midchan[all_1.iv + kv * 24 - 25];
/* A rather klugey way to set flag for figure in this voice */
/* Must always check figbass before figchk. */
if (all_1.figbass) {
ivf = 0;
if (commvl_1.ivx == 1) {
ivf = 1;
} else if (commvl_1.ivx == comfig_1.ivxfig2) {
ivf = 2;
}
if (ivf > 0) {
all_1.figchk[ivf - 1] = comfig_1.nfigs[ivf - 1] > 0;
}
}
if (commvl_1.ivx > 1) {
if (commvl_1.ivx <= all_1.nv) {
addstr_(all_1.sepsymq + (all_1.iv - 2), &c__1, soutq,
&lsout, (ftnlen)1, (ftnlen)80);
} else {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 9, a__2[1] = "nextvoice";
s_cat(ch__8, a__2, i__4, &c__2, (ftnlen)10);
addstr_(ch__8, &c__10, soutq, &lsout, (ftnlen)10, (
ftnlen)80);
}
}
if (comhead_1.ihdht > 0 && commvl_1.ivx == all_1.nv) {
/* Write header. First adjust height if needed to miss barno. */
if (comask_1.bar1syst && all_1.iline != 1) {
comhead_1.ihdht = comsln_1.irzbnd + 15 +
comsln_1.isnx;
}
/* Add user-defined vertical shift */
comhead_1.ihdht += comhead_1.ihdvrt;
lchead = lenstr_(comhead_1.headrq, &c__80, (ftnlen)80);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 10, a__2[1] = "zcharnote{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
s_wsfi(&io___1029);
do_fio(&c__1, (char *)&comhead_1.ihdht, (ftnlen)sizeof(
integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 13, a__1[0] = notexq;
i__3[1] = 2, a__1[1] = "}{";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 7, a__1[3] = "bigfont";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 10, a__1[5] = "kern-30pt ";
s_cat(notexq, a__1, i__3, &c__6, (ftnlen)79);
addstr_(notexq, &c__34, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
/* Writing concatenation */
i__4[0] = lchead, a__2[0] = comhead_1.headrq;
i__4[1] = 1, a__2[1] = "}";
s_cat(ch__10, a__2, i__4, &c__2, (ftnlen)81);
i__9 = lchead + 1;
addstr_(ch__10, &i__9, soutq, &lsout, lchead + 1, (ftnlen)
80);
comhead_1.ihdht = 0;
}
if (comhead_1.lower && commvl_1.ivx == all_1.nv) {
lclow = lenstr_(comhead_1.lowerq, &c__80, (ftnlen)80);
/* Writing concatenation */
i__10[0] = 1, a__6[0] = all_1.sq;
i__10[1] = 14, a__6[1] = "zcharnote{-6}{";
i__10[2] = 1, a__6[2] = all_1.sq;
i__10[3] = 5, a__6[3] = "tempo";
i__10[4] = 1, a__6[4] = all_1.sq;
i__10[5] = 10, a__6[5] = "kern-10pt ";
i__10[6] = lclow, a__6[6] = comhead_1.lowerq;
i__10[7] = 1, a__6[7] = "}";
s_cat(ch__11, a__6, i__10, &c__8, (ftnlen)113);
i__9 = lclow + 33;
addstr_(ch__11, &i__9, soutq, &lsout, lclow + 33, (ftnlen)
80);
comhead_1.lower = FALSE_;
}
tnow = tstart[ib];
nofirst = TRUE_;
/* Done setting up voice ivx for start of block ib. Loop over notes in voice. */
i__9 = istop[ib];
for (all_1.jn = istart[ib]; all_1.jn <= i__9; ++all_1.jn) {
if (all_1.ivxo[all_1.jn - 1] != commvl_1.ivx) {
goto L10;
}
ip = all_1.ipo[all_1.jn - 1];
/* May have problem with not initializing islhgt, so do it here */
islhgt = 0;
if (nofirst) {
comoct_1.noctup = 0;
if (ncmid_(&all_1.iv, &ip) == 23) {
comoct_1.noctup = -2;
}
nofirst = FALSE_;
}
/* Check for internal floating figure (before last note of group). */
L12:
if (all_1.figbass) {
if (commvl_1.ivx == 1 || commvl_1.ivx ==
comfig_1.ivxfig2) {
ivf = 1;
if (commvl_1.ivx > 1) {
ivf = 2;
}
if (all_1.figchk[ivf - 1] && (real)
comfig_1.itfig[ivf + (ifig[ivf - 1] << 1)
- 3] < tnow - comtol_1.tol) {
/* Bypassed figure location. Backup, place fig, return. */
offnsk = (tnow - comfig_1.itfig[ivf + (ifig[
ivf - 1] << 1) - 3]) / comnsp_2.space[
ib - 1];
putfig_(&ivf, &ifig[ivf - 1], &offnsk, &
all_1.figchk[ivf - 1], soutq, &lsout,
(ftnlen)80);
goto L12;
}
}
}
/* Put in \sk if needed */
if (all_1.to[all_1.jn - 1] > tnow + comtol_1.tol) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 2, a__2[1] = "sk";
s_cat(ch__12, a__2, i__4, &c__2, (ftnlen)3);
addstr_(ch__12, &c__3, soutq, &lsout, (ftnlen)3, (
ftnlen)80);
tnow += comnsp_2.space[ib - 1];
goto L12;
}
/* Check for user-defined shifts */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],15)
|| bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],16)) {
putshft_(&commvl_1.ivx, &c_true, soutq, &lsout, (
ftnlen)80);
}
L21:
if (iaskb[commvl_1.ivx - 1] <= comas1_1.naskb && tnow >
comas1_1.task[iaskb[commvl_1.ivx - 1] - 1] -
comtol_1.tol) {
if (comas1_1.task[iaskb[commvl_1.ivx - 1] - 1] >
tstart[ib] - comtol_1.tol) {
/* Insert placeholder for accidental skip */
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 8, a__2[1] = "ask ";
s_cat(ch__13, a__2, i__4, &c__2, (ftnlen)9);
addstr_(ch__13, &c__9, soutq, &lsout, (ftnlen)9, (
ftnlen)80);
++comas2_1.nasksys;
comas2_1.wasksys[comas2_1.nasksys - 1] =
comas1_1.wask[iaskb[commvl_1.ivx - 1] - 1]
;
if (comas1_1.wask[iaskb[commvl_1.ivx - 1] - 1] >
0.f) {
comas2_1.elasksys[comas2_1.nasksys - 1] =
comas1_1.elask[iaskb[commvl_1.ivx - 1]
- 1];
} else {
/* This is a signal to permit negative ask's. Should really have elask>=0. */
comas2_1.elasksys[comas2_1.nasksys - 1] =
-comas1_1.elask[iaskb[commvl_1.ivx -
1] - 1];
}
}
/* May have skipped some task's in earlier blocks (due to void voice) */
++iaskb[commvl_1.ivx - 1];
goto L21;
}
if (all_1.figbass) {
if (commvl_1.ivx == 1 || commvl_1.ivx ==
comfig_1.ivxfig2) {
ivf = 1;
if (commvl_1.ivx > 1) {
ivf = 2;
}
if (all_1.figchk[ivf - 1] && (r__1 =
comfig_1.itfig[ivf + (ifig[ivf - 1] << 1)
- 3] - tnow, dabs(r__1)) < comtol_1.tol) {
/* Figure on a note. NB: later special check for late figs. */
putfig_(&ivf, &ifig[ivf - 1], &c_b762, &
all_1.figchk[ivf - 1], soutq, &lsout,
(ftnlen)80);
}
}
}
/* Check for new clef here. */
if (isclef && bit_test(all_1.islur[commvl_1.ivx + ip * 24
- 25],11)) {
/* print*,'At clef insertion, ptclef:',ptclef(iv) */
if (ptclef[all_1.iv - 1] > 0.f) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "off{-";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
if (ptclef[all_1.iv - 1] < 9.95f) {
s_wsfi(&io___1035);
do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], (
ftnlen)sizeof(real));
e_wsfi();
lnote = 9;
} else {
s_wsfi(&io___1036);
do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], (
ftnlen)sizeof(real));
e_wsfi();
lnote = 10;
}
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 3, a__2[1] = "pt}";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += 3;
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79,
(ftnlen)80);
/* print*,'Just added: ',notexq(1:lnote) */
}
clefsym_(&all_1.islur[all_1.iv + ip * 24 - 25],
notexq, &lnote, &nclef, (ftnlen)79);
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
if (ptclef[all_1.iv - 1] > 0.f) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 4, a__2[1] = "off{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
if (ptclef[all_1.iv - 1] < 9.95f) {
s_wsfi(&io___1038);
do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], (
ftnlen)sizeof(real));
e_wsfi();
lnote = 8;
} else {
s_wsfi(&io___1039);
do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], (
ftnlen)sizeof(real));
e_wsfi();
lnote = 9;
}
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 3, a__2[1] = "pt}";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += 3;
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79,
(ftnlen)80);
}
}
/* Checking for literal TeX string BEFORE starting beams!! */
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],16))
{
i__11 = comgrace_1.nlit;
for (il = 1; il <= i__11; ++il) {
if (comgrace_1.iplit[il - 1] == ip &&
comgrace_1.ivlit[il - 1] == commvl_1.ivx)
{
goto L125;
}
/* L124: */
}
s_wsle(&io___1041);
do_lio(&c__9, &c__1, "Problem finding index for lite"
"ral string", (ftnlen)40);
e_wsle();
stop1_();
L125:
/* Write a type 1 tex string. */
if (comgrace_1.lenlit[il - 1] < 71) {
/* Add normally */
addstr_(comgrace_1.litq + (il - 1 << 7), &
comgrace_1.lenlit[il - 1], soutq, &lsout,
(ftnlen)128, (ftnlen)80);
} else {
/* Longer than 71. Write souq, Write string, start new soutq. */
if (comlast_1.islast) {
s_wsfe(&io___1042);
/* Writing concatenation */
i__4[0] = lsout, a__2[0] = soutq;
i__4[1] = 1, a__2[1] = "%";
s_cat(ch__10, a__2, i__4, &c__2, (ftnlen)81);
do_fio(&c__1, ch__10, lsout + 1);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1043);
/* Writing concatenation */
i__4[0] = comgrace_1.lenlit[il - 1], a__2[0] =
comgrace_1.litq + (il - 1 << 7);
i__4[1] = 1, a__2[1] = "%";
s_cat(ch__14, a__2, i__4, &c__2, (ftnlen)129);
do_fio(&c__1, ch__14, comgrace_1.lenlit[il -
1] + 1);
e_wsfe();
}
lsout = 0;
}
}
/* Arpeggio on a main (non-chordal) note? */
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],27))
{
/* call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), */
i__11 = ncmid_(&all_1.iv, &ip);
putarp_(&tnow, &commvl_1.ivx, &ip, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &i__11, soutq, &
lsout, (ftnlen)80);
}
/* See if a beam starts here */
if (numbms[commvl_1.ivx] > 0 && all_1.ibmcnt[commvl_1.ivx
- 1] <= numbms[commvl_1.ivx] && all_1.ibm1[
commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] *
24 - 25] == ip || bit_test(all_1.nacc[
commvl_1.ivx + ip * 24 - 25],21)) {
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],24)) {
/* Not a jump start */
if (comkbdrests_1.kbdrests && bit_test(
all_1.irest[commvl_1.ivx + ip * 24 - 25],
0) && ! bit_test(all_1.islur[commvl_1.ivx
+ ip * 24 - 25],29) && commvl_1.nvmx[
all_1.iv - 1] == 2 && all_1.nolev[
commvl_1.ivx + ip * 24 - 25] <= 50) {
chkkbdrests_(&ip, &all_1.iv, &commvl_1.ivx,
all_1.nn, all_1.iornq, all_1.islur,
all_1.irest, all_1.nolev,
commvl_1.ivmx, all_1.nib, &all_1.nv, &
all_1.ibar, &tnow, &comtol_1.tol,
all_1.nodur, &c__2,
comkbdrests_1.levtopr,
comkbdrests_1.levbotr, all_1.mult);
}
beamstrt_(notexq, &lnote, nornb, ihornb,
comnsp_2.space, &squez[1], &ib, (ftnlen)
79);
/* Shift beam start if notehead was shifted */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 -
25],8)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "loff{";
s_cat(ch__15, a__2, i__4, &c__2, (ftnlen)6);
addstr_(ch__15, &c__6, soutq, &lsout, (ftnlen)
6, (ftnlen)80);
} else if (bit_test(all_1.ipl[commvl_1.ivx + ip *
24 - 25],9)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "roff{";
s_cat(ch__15, a__2, i__4, &c__2, (ftnlen)6);
addstr_(ch__15, &c__6, soutq, &lsout, (ftnlen)
6, (ftnlen)80);
}
if (lnote > 0) {
addstr_(notexq, &lnote, soutq, &lsout, (
ftnlen)79, (ftnlen)80);
}
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 -
25],8) || bit_test(all_1.ipl[commvl_1.ivx
+ ip * 24 - 25],9)) {
addstr_("}", &c__1, soutq, &lsout, (ftnlen)1,
(ftnlen)80);
}
} else {
/* Jump start. Set marker for second part of a jump beam. Note ivbj2 was set */
/* to 0 at end of first part of jump beam */
combjmp_1.ivbj2 = commvl_1.ivx;
/* Check for xtup since we bypassed beamstrt wherein vxtup is normally set */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],28) && strtmid_1.ixrest[commvl_1.ivx
- 1] != 2) {
comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_;
}
/* Since beamstrt is not called, and drawbm is normally set there, need to set */
/* it here. This could cause problems if someone tries a staff-jumping, */
/* unbarred beam, which I'll deal with when it comes up. */
comdraw_1.drawbm[commvl_1.ivx - 1] = TRUE_;
}
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0) {
all_1.beamon[commvl_1.ivx - 1] = TRUE_;
bspend = TRUE_;
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24
- 25],24)) {
bspend = TRUE_;
}
}
}
/* Setup for chords and possible slurs in chords */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* There is a chord on this note. Just rerun precrd. Klunky, but saves */
/* me from tracking down errors instroduced when I moved 1st call */
/* forward for accidental spacing analysis. */
if (all_1.beamon[commvl_1.ivx - 1]) {
precrd_(&commvl_1.ivx, &ip, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &all_1.nacc[
commvl_1.ivx + ip * 24 - 25], &all_1.ipl[
commvl_1.ivx + ip * 24 - 25], &
all_1.irest[commvl_1.ivx + ip * 24 - 25],
all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &c_true, &
icashft, (ftnlen)1);
} else {
i__11 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[commvl_1.ivx
+ ip * 24 - 25], &i__11, &all_1.islur[
commvl_1.ivx + ip * 24 - 25], &
commvl_1.nvmx[all_1.iv - 1], &
commvl_1.ivx, &all_1.nv);
precrd_(&commvl_1.ivx, &ip, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &all_1.nacc[
commvl_1.ivx + ip * 24 - 25], &all_1.ipl[
commvl_1.ivx + ip * 24 - 25], &
all_1.irest[commvl_1.ivx + ip * 24 - 25],
ch__4, &c_true, &icashft, (ftnlen)1);
}
}
/* Is there slur or grace activity? */
isgrace = bit_test(all_1.islur[commvl_1.ivx + ip * 24 -
25],4);
if (ip > 1) {
isgrace = isgrace || bit_test(all_1.ipl[commvl_1.ivx
+ (ip - 1) * 24 - 25],31);
}
/* isgrace if not 1st note in bar and previous note has Way-after grace. */
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],0)
|| isgrace) {
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],
0)) {
if (comslur_1.fontslur) {
/* Call routine for non-postscript slurs */
i__11 = ncmid_(&all_1.iv, &ip);
doslur_(&all_1.nolev[commvl_1.ivx + ip * 24 -
25], all_1.isdat1, all_1.isdat2,
all_1.isdat3, &all_1.nsdat, &ip, &
all_1.iv, &kv, &all_1.nv, &
all_1.beamon[commvl_1.ivx - 1], &
i__11, soutq, &lsout, all_1.ulq + (
commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25), &
all_1.islur[commvl_1.ivx + ip * 24 -
25], &all_1.ipl[commvl_1.ivx + ip *
24 - 25], &all_1.iornq[commvl_1.ivx +
ip * 24 - 1], &islhgt, &all_1.tnote[
comipl2_1.ipl2[commvl_1.ivx + ip * 24
- 25] - 1], &all_1.nacc[commvl_1.ivx
+ ip * 24 - 25], (ftnlen)80, (ftnlen)
1);
} else {
/* Postscript slurs */
i__11 = ncmid_(&all_1.iv, &ip);
dopsslur_(&all_1.nolev[commvl_1.ivx + ip * 24
- 25], all_1.isdat1, all_1.isdat2,
all_1.isdat3, all_1.isdat4, &
all_1.nsdat, &ip, &all_1.iv, &kv, &
all_1.nv, &all_1.beamon[commvl_1.ivx
- 1], &i__11, soutq, &lsout,
all_1.ulq + (commvl_1.ivx +
all_1.ibmcnt[commvl_1.ivx - 1] * 24 -
25), &all_1.islur[commvl_1.ivx + ip *
24 - 25], &all_1.ipl[commvl_1.ivx +
ip * 24 - 25], &all_1.iornq[
commvl_1.ivx + ip * 24 - 1], &islhgt,
&all_1.tnote[comipl2_1.ipl2[
commvl_1.ivx + ip * 24 - 25] - 1], &
all_1.nacc[commvl_1.ivx + ip * 24 -
25], (ftnlen)80, (ftnlen)1);
}
}
if (isgrace) {
/* Grace note. */
iphold = ip;
isgrace = FALSE_;
if (ip > 1) {
isgrace = bit_test(all_1.ipl[commvl_1.ivx + (
ip - 1) * 24 - 25],31);
}
if (isgrace) {
--iphold;
}
isgrace = isgrace || ! bit_test(all_1.ipl[
commvl_1.ivx + ip * 24 - 25],31) && !
bit_test(all_1.ipl[commvl_1.ivx + ip * 24
- 25],29);
/* Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace */
/* on current note. Do A-grace on current note, and W-grace at barend, later. */
if (isgrace) {
i__11 = ncmid_(&all_1.iv, &ip);
i__12 = ncmid_(&all_1.iv, &ip);
dograce_(&commvl_1.ivx, &iphold, ptgr, soutq,
&lsout, &i__11, &all_1.nacc[
commvl_1.ivx + ip * 24 - 25], &ig, &
all_1.ipl[commvl_1.ivx + iphold * 24
- 25], &c_false, &all_1.beamon[
commvl_1.ivx - 1], &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &i__12,
&all_1.islur[commvl_1.ivx + ip * 24 -
25], &commvl_1.nvmx[all_1.iv - 1], &
all_1.nv, &all_1.ibmcnt[commvl_1.ivx
- 1], &all_1.tnote[comipl2_1.ipl2[
commvl_1.ivx + ip * 24 - 25] - 1],
all_1.ulq, &cominsttrans_1.instno[
all_1.iv - 1], (ftnlen)80, (ftnlen)1);
/* 130324 */
/* * tnote(ipl2(ivx,ip)),ulq) */
if (comgrace_1.slurg[ig - 1]) {
/* Terminate slur started in dograce. Get direction of main note stem */
if (! all_1.beamon[commvl_1.ivx - 1]) {
/* Separate note. Get stem direction. */
i__11 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25],
&i__11, &all_1.islur[
commvl_1.ivx + ip * 24 - 25],
&commvl_1.nvmx[all_1.iv - 1],
&commvl_1.ivx, &all_1.nv);
stemup = *(unsigned char *)&ch__4[0]
== 'u';
} else {
/* In a beam */
stemup = *(unsigned char *)&all_1.ulq[
commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25]
== 'u';
}
/* Stop the shift if whole note */
stemup = stemup || all_1.tnote[
comipl2_1.ipl2[commvl_1.ivx + ip *
24 - 25] - 1] > 63.f;
L__1 = ! comgrace_1.upg[ig - 1];
i__11 = ncmid_(&all_1.iv, &ip);
endslur_(&stemup, &L__1, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &
c__0, &comslur_1.ndxslur, &c__0, &
i__11, soutq, &lsout, &
comslur_1.fontslur, (ftnlen)80);
}
}
}
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],
24)) {
/* Start slur on main note for After- or Way-after-grace. */
/* ???? ndxslur = log2(33554431-listslur) */
i__11 = 16777215 - comslur_1.listslur;
comslur_1.ndxslur = log2_(&i__11);
/* Get note name */
i__11 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &all_1.nolev[commvl_1.ivx
+ ip * 24 - 25], &i__11, (ftnlen)8);
/* Get slur direction */
*(unsigned char *)slurudq = 'u';
if (! all_1.beamon[commvl_1.ivx - 1]) {
i__11 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &i__11,
&all_1.islur[commvl_1.ivx + ip * 24 -
25], &commvl_1.nvmx[all_1.iv - 1], &
commvl_1.ivx, &all_1.nv);
if (*(unsigned char *)&ch__4[0] == 'u') {
*(unsigned char *)slurudq = 'd';
}
} else {
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx
+ all_1.ibmcnt[commvl_1.ivx - 1] * 24
- 25] == 'u') {
*(unsigned char *)slurudq = 'd';
}
}
/* c Replace ndxslur by 11-ndxslur when printing only. */
/* Replace ndxslur by 23-ndxslur when printing only. */
/* if (11-ndxslur .lt. 10) then */
if (23 - comslur_1.ndxslur < 10) {
/* notexq = sq//'islur'//slurudq//chax(59-ndxslur) */
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 5, a__3[1] = "islur";
i__5[2] = 1, a__3[2] = slurudq;
i__11 = 71 - comslur_1.ndxslur;
chax_(ch__4, (ftnlen)1, &i__11);
i__5[3] = 1, a__3[3] = ch__4;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
i__11 = lnoten + 8;
addstr_(notexq, &i__11, soutq, &lsout, (
ftnlen)79, (ftnlen)80);
} else if (23 - comslur_1.ndxslur < 20) {
/* Writing concatenation */
i__13[0] = 1, a__7[0] = all_1.sq;
i__13[1] = 5, a__7[1] = "islur";
i__13[2] = 1, a__7[2] = slurudq;
i__13[3] = 2, a__7[3] = "{1";
i__11 = 61 - comslur_1.ndxslur;
chax_(ch__4, (ftnlen)1, &i__11);
i__13[4] = 1, a__7[4] = ch__4;
i__13[5] = 1, a__7[5] = "}";
i__13[6] = lnoten, a__7[6] = noteq;
s_cat(notexq, a__7, i__13, &c__7, (ftnlen)79);
i__11 = lnoten + 11;
addstr_(notexq, &i__11, soutq, &lsout, (
ftnlen)79, (ftnlen)80);
} else {
/* Writing concatenation */
i__13[0] = 1, a__7[0] = all_1.sq;
i__13[1] = 5, a__7[1] = "islur";
i__13[2] = 1, a__7[2] = slurudq;
i__13[3] = 2, a__7[3] = "{2";
i__11 = 51 - comslur_1.ndxslur;
chax_(ch__4, (ftnlen)1, &i__11);
i__13[4] = 1, a__7[4] = ch__4;
i__13[5] = 1, a__7[5] = "}";
i__13[6] = lnoten, a__7[6] = noteq;
s_cat(notexq, a__7, i__13, &c__7, (ftnlen)79);
i__11 = lnoten + 11;
addstr_(notexq, &i__11, soutq, &lsout, (
ftnlen)79, (ftnlen)80);
}
/* call setbits(ipl(ivx,ip),4,23,ndxslur) */
setbits_(&all_1.ipl[commvl_1.ivx + ip * 24 - 25],
&c__5, &c__23, &comslur_1.ndxslur);
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 -
25],31)) {
comslur_1.listslur = bit_set(
comslur_1.listslur,comslur_1.ndxslur);
}
/* Starting slur on W-grace on THIS note. Record ndxslur. */
}
}
/* Process dynamic marks */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],26))
{
i__11 = ncmid_(&all_1.iv, &ip);
L__1 = all_1.nodur[commvl_1.ivx + ip * 24 - 25] >= 64;
dodyn_(&commvl_1.ivx, &ip, &all_1.nolev[commvl_1.ivx
+ ip * 24 - 25], &i__11, &all_1.ipl[
commvl_1.ivx + ip * 24 - 25], &all_1.islur[
commvl_1.ivx + ip * 24 - 25], &all_1.irest[
commvl_1.ivx + ip * 24 - 25], &commvl_1.nvmx[
all_1.iv - 1], &all_1.nv, &all_1.beamon[
commvl_1.ivx - 1], ihornb, nornb, all_1.ulq, &
all_1.ibmcnt[commvl_1.ivx - 1], &L__1, soutq,
&lsout, (ftnlen)1, (ftnlen)80);
}
/* Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) {
/* Need a duration to set type of note head */
/* if (.not. vxtup(ivx)) then */
/* Clumsy test, but vxtup is not set until main note is processed. */
if (! (comxtup_1.vxtup[commvl_1.ivx - 1] || bit_test(
all_1.irest[commvl_1.ivx + ip * 24 - 25],28)))
{
nodu = all_1.nodur[commvl_1.ivx + ip * 24 - 25];
/* else if (mult(ivx,ip) .lt. 0) then */
} else if ((all_1.mult[commvl_1.ivx + ip * 24 - 25] &
15) - 8 < 0) {
nodu = 32;
} else {
nodu = 16;
}
i__11 = ncmid_(&all_1.iv, &ip);
L__1 = bit_test(all_1.nacc[commvl_1.ivx + ip * 24 -
25],27);
docrd_(&commvl_1.ivx, &ip, &nodu, &i__11, &all_1.iv, &
tnow, soutq, &lsout, all_1.ulq, &all_1.ibmcnt[
commvl_1.ivx - 1], &all_1.islur[commvl_1.ivx
+ ip * 24 - 25], &commvl_1.nvmx[all_1.iv - 1],
&all_1.nv, &all_1.beamon[commvl_1.ivx - 1], &
all_1.nolev[commvl_1.ivx + ip * 24 - 25],
ihornb, nornb, &all_1.stemlen, &L__1, &
all_1.nacc[commvl_1.ivx + ip * 24 - 25], (
ftnlen)80, (ftnlen)1);
}
/* Now that chords are done, add stuff to midi file */
if (commidi_1.ismidi) {
i__11 = all_1.nolev[commvl_1.ivx + ip * 24 - 25] +
commvel_1.miditran[cominsttrans_1.instno[
all_1.iv - 1] - 1];
i__12 = all_1.nacc[commvl_1.ivx + ip * 24 - 25] & 7;
L__1 = bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],0);
addmidi_(&icm, &i__11, &i__12, &commidisig_1.midisig,
&all_1.tnote[comipl2_1.ipl2[commvl_1.ivx + ip
* 24 - 25] - 1], &L__1, &c_false);
}
/* 130316 */
/* * nolev(ivx,ip)-iTransAmt(instno(iv)), */
/* * iand(nacc(ivx,ip),7),midisig(instno(iv)), */
/* Check for breath or caesura */
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],28))
{
putcb_(&commvl_1.ivx, &ip, notexq, &lnote, (ftnlen)79)
;
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
}
/* Check for main-note ornaments. ')' on dotted notes go in with note, not here. */
/* Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F */
/* 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD */
isacc = (all_1.iornq[commvl_1.ivx + ip * 24 - 1] &
4194287) > 0;
/* isacc=.true. if any ornament except segno */
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)
&& all_1.nodur[commvl_1.ivx + ip * 24 - 25] > 0) {
/* If ). is only ornament, bypass. If with others, temporarirly zero the bit. */
i__11 = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 -
25]);
if (pow_ii(&c__2, &i__11) != all_1.nodur[commvl_1.ivx
+ ip * 24 - 25]) {
if ((all_1.iornq[commvl_1.ivx + ip * 24 - 1] &
516079) == 0) {
/* ). is the only non-segno ornament */
isacc = FALSE_;
} else {
/* There are other ornaments in addition */
rpndot = TRUE_;
all_1.iornq[commvl_1.ivx + ip * 24 - 1] =
bit_clear(all_1.iornq[commvl_1.ivx +
ip * 24 - 1],13);
}
}
}
if (isacc && ! comcwrf_1.cwrferm[commvl_1.ivx - 1]) {
/* Check for centered whole-bar rest with fermata (bits 10 or 14). */
if ((all_1.iornq[commvl_1.ivx + ip * 24 - 1] & 17408)
> 0 && bit_test(all_1.irest[commvl_1.ivx + ip
* 24 - 25],0) && all_1.nodur[commvl_1.ivx +
ip * 24 - 25] == all_1.lenbar && ! (
all_1.firstgulp && all_1.ibar == 1 &&
all_1.lenb0 > 0)) {
comcwrf_1.cwrferm[commvl_1.ivx - 1] = TRUE_;
goto L30;
}
i__11 = ncmid_(&all_1.iv, &ip);
L__1 = bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25]
,10);
putorn_(&all_1.iornq[commvl_1.ivx + ip * 24 - 1], &
all_1.nolev[commvl_1.ivx + ip * 24 - 25], &
all_1.nolev[commvl_1.ivx + ip * 24 - 25], &
all_1.nodur[commvl_1.ivx + ip * 24 - 25],
nornb, all_1.ulq, &all_1.ibmcnt[commvl_1.ivx
- 1], &commvl_1.ivx, &i__11, &all_1.islur[
commvl_1.ivx + ip * 24 - 25], &commvl_1.nvmx[
all_1.iv - 1], &all_1.nv, ihornb, &
all_1.stemlen, notexq, &lnote, &ip, &islhgt, &
all_1.beamon[commvl_1.ivx - 1], &L__1, (
ftnlen)1, (ftnlen)79);
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
}
if (rpndot) {
all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set(
all_1.iornq[commvl_1.ivx + ip * 24 - 1],13);
rpndot = FALSE_;
}
L30:
/* Check for main note accidental */
if ((all_1.nacc[commvl_1.ivx + ip * 24 - 25] & 3) > 0 && !
bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],
17)) {
ihshft = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24
- 25], &c__7, &c__10);
if (ihshft != 0) {
ihshft += -107;
}
if (! bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],
10) && bit_test(all_1.ipl[commvl_1.ivx + ip *
24 - 25],8)) {
ihshft += -20;
}
/* Not a chord, and left-shifted main note, so left-shift accid */
i__11 = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24
- 25], &c__6, &c__4);
i__12 = ncmid_(&all_1.iv, &ip);
L__1 = bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],31);
doacc_(&ihshft, &i__11, notexq, &lnote, &all_1.nacc[
commvl_1.ivx + ip * 24 - 25], &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &i__12, &L__1, (
ftnlen)79);
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
}
/* Lower dot for lower-voice notes. Conditions are: */
/* 1. Dotted time value */
/* 2. Lower voice of two */
/* 3. Note is on a line */
/* 4. Not a rest */
/* . 5. Flag (lowdot) is set to true */
/* 6. Not in an xtuplet */
if (comarp_1.lowdot && commvl_1.nvmx[all_1.iv - 1] == 2 &&
commvl_1.ivx <= all_1.nv && all_1.nodur[
commvl_1.ivx + ip * 24 - 25] != 0) {
i__11 = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 -
25]);
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],0) && pow_ii(&c__2, &i__11) !=
all_1.nodur[commvl_1.ivx + ip * 24 - 25] && (
all_1.nolev[commvl_1.ivx + ip * 24 - 25] -
ncmid_(&commvl_1.ivx, &ip)) % 2 == 0) {
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],19)) {
/* Note already in movdot list. Drop by 2. */
comcc_1.updot[commvl_1.ivx + (comcc_1.ndotmv[
commvl_1.ivx - 1] + 1) * 24 - 25] +=
-2.f;
} else {
/* Not in list so just move it right now */
i__11 = igetbits_(&all_1.islur[commvl_1.ivx +
ip * 24 - 25], &c__1, &c__3);
dotmov_(&c_b761, &c_b762, soutq, &lsout, &
i__11, (ftnlen)80);
}
}
}
/* Check for dotted notes with moved dots */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],19))
{
++comcc_1.ndotmv[commvl_1.ivx - 1];
i__11 = igetbits_(&all_1.islur[commvl_1.ivx + ip * 24
- 25], &c__1, &c__3);
dotmov_(&comcc_1.updot[commvl_1.ivx + comcc_1.ndotmv[
commvl_1.ivx - 1] * 24 - 25], &comcc_1.rtdot[
commvl_1.ivx + comcc_1.ndotmv[commvl_1.ivx -
1] * 24 - 25], soutq, &lsout, &i__11, (ftnlen)
80);
}
/* Stemlength shortening? */
if (bit_test(all_1.mult[commvl_1.ivx + ip * 24 - 25],27))
{
stemshort = 4.66f - (igetbits_(&all_1.mult[
commvl_1.ivx + ip * 24 - 25], &c__3, &c__28)
+ 1) * .667f * .5f;
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 11, a__2[1] = "stemlength{";
s_cat(ch__3, a__2, i__4, &c__2, (ftnlen)12);
addstr_(ch__3, &c__12, soutq, &lsout, (ftnlen)12, (
ftnlen)80);
s_wsfi(&io___1050);
do_fio(&c__1, (char *)&stemshort, (ftnlen)sizeof(real)
);
e_wsfi();
/* Writing concatenation */
i__4[0] = 4, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "}";
s_cat(ch__16, a__2, i__4, &c__2, (ftnlen)5);
addstr_(ch__16, &c__5, soutq, &lsout, (ftnlen)5, (
ftnlen)80);
} else if (ip > 1) {
if (bit_test(all_1.mult[commvl_1.ivx + (ip - 1) * 24
- 25],27)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 16, a__2[1] = "stemlength{4.66}";
s_cat(ch__5, a__2, i__4, &c__2, (ftnlen)17);
addstr_(ch__5, &c__17, soutq, &lsout, (ftnlen)17,
(ftnlen)80);
}
/* Cancel shortening. Looks like it gets automatically restored if new inst. or */
/* new line, so no need to worry about affecting other lines */
}
/* Zero out slur-height marker for raising ornaments */
islhgt = 0;
/* Now start with spacing notes. Is a beam start pending? */
if (bspend && all_1.ibm2[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25] > all_1.ibm1[
commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] *
24 - 25]) {
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 4) {
/* Special path for single note at end of otherwise beamed xtup */
strtmid_1.ixrest[commvl_1.ivx - 1] = 0;
} else {
if (comkbdrests_1.kbdrests && bit_test(
all_1.irest[commvl_1.ivx + ip * 24 - 25],
0) && ! bit_test(all_1.islur[commvl_1.ivx
+ ip * 24 - 25],29) && commvl_1.nvmx[
all_1.iv - 1] == 2 && all_1.nolev[
commvl_1.ivx + ip * 24 - 25] <= 50) {
chkkbdrests_(&ip, &all_1.iv, &commvl_1.ivx,
all_1.nn, all_1.iornq, all_1.islur,
all_1.irest, all_1.nolev,
commvl_1.ivmx, all_1.nib, &all_1.nv, &
all_1.ibar, &tnow, &comtol_1.tol,
all_1.nodur, &c__2,
comkbdrests_1.levtopr,
comkbdrests_1.levbotr, all_1.mult);
}
beamn1_(notexq, &lnote, (ftnlen)79);
}
bspend = FALSE_;
/* Is a beam ending? */
} else if (numbms[commvl_1.ivx] > 0 && all_1.ibmcnt[
commvl_1.ivx - 1] <= numbms[commvl_1.ivx] && (
all_1.ibm2[commvl_1.ivx + all_1.ibmcnt[
commvl_1.ivx - 1] * 24 - 25] == ip || bit_test(
all_1.nacc[commvl_1.ivx + ip * 24 - 25],20))) {
/* * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then */
if (bspend) {
/* Must be a single-note ending of a jump-beam */
bspend = FALSE_;
}
beamend_(notexq, &lnote, (ftnlen)79);
if (! bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25]
,20)) {
comxtup_1.vxtup[commvl_1.ivx - 1] = FALSE_;
nornb[commvl_1.ivx - 1] = 0;
++all_1.ibmcnt[commvl_1.ivx - 1];
all_1.beamon[commvl_1.ivx - 1] = FALSE_;
}
/* Or if we're in the middle of a beam */
} else if (numbms[commvl_1.ivx] > 0 && all_1.beamon[
commvl_1.ivx - 1]) {
/* Added 130127 */
if (comkbdrests_1.kbdrests && bit_test(all_1.irest[
commvl_1.ivx + ip * 24 - 25],0) && ! bit_test(
all_1.islur[commvl_1.ivx + ip * 24 - 25],29)
&& commvl_1.nvmx[all_1.iv - 1] == 2 &&
all_1.nolev[commvl_1.ivx + ip * 24 - 25] <=
50) {
chkkbdrests_(&ip, &all_1.iv, &commvl_1.ivx,
all_1.nn, all_1.iornq, all_1.islur,
all_1.irest, all_1.nolev, commvl_1.ivmx,
all_1.nib, &all_1.nv, &all_1.ibar, &tnow,
&comtol_1.tol, all_1.nodur, &c__2,
comkbdrests_1.levtopr,
comkbdrests_1.levbotr, all_1.mult);
}
beamid_(notexq, &lnote, (ftnlen)79);
/* Or whole-bar rest */
} else if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],0) && all_1.nodur[commvl_1.ivx + ip * 24 - 25]
== all_1.lenbar && ! (all_1.firstgulp &&
all_1.ibar == 1 && all_1.lenb0 > 0) && ! bit_test(
all_1.irest[commvl_1.ivx + ip * 24 - 25],25) && !
bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],
29)) {
/* Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp */
cwrest[commvl_1.ivx] = TRUE_;
iscwr = TRUE_;
notex_(cwrq + (commvl_1.ivx - 1) * 79, &lcwr[
commvl_1.ivx - 1], (ftnlen)79);
tnow += all_1.lenbar;
goto L10;
} else if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0) {
/* Before writing note or rest, check for keyboard rest height adjustment. */
/* Conditions are 0. This is a non-blank rest */
/* 1. kbdrests = .true. */
/* 2. There are two voices on the staff */
/* 3. No user-def height adjustments have been applied (nolev<50) */
/* c 4. Not last note in bar */
/* c 5. Followed by note (add better test later) */
if (comkbdrests_1.kbdrests && bit_test(all_1.irest[
commvl_1.ivx + ip * 24 - 25],0) && ! bit_test(
all_1.islur[commvl_1.ivx + ip * 24 - 25],29)
&& commvl_1.nvmx[all_1.iv - 1] == 2 &&
all_1.nolev[commvl_1.ivx + ip * 24 - 25] <=
50) {
/* * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) */
/* * .and. .not.(btest(irest(ivx,ip+1),0))) then */
/* 130127 Replaced following code with a subroutine */
/* c Get reference level: next following note if no intervening blank rests, */
/* c otherwise next prior note. */
/* c */
/* c levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line */
/* if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then */
/* c */
/* c Not the last note and not "look-left" for level */
/* c */
/* do 8 kkp = ip+1 , nn(ivx) */
/* if (btest(islur(ivx,kkp),29)) go to 4 */
/* if (.not.btest(irest(ivx,kkp),0)) then */
/* levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line */
/* go to 9 */
/* end if */
/* 8 continue */
/* end if */
/* 4 continue */
/* c */
/* c If here, there were no following notes or came to a blank rest, or */
/* c "look-left" option set. So look before */
/* c */
/* if (ip .eq. 1) go to 2 ! Get out if this is the first note. */
/* do 3 kkp = ip-1, 1, -1 */
/* if (.not.btest(irest(ivx,kkp),0)) then */
/* levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line */
/* go to 9 */
/* end if */
/* 3 continue */
/* go to 2 ! Pretty odd, should never be here, but get out if so. */
/* 9 continue */
/* c */
/* c Find note in other voice at same time */
/* c */
/* iupdown = sign(1,ivx-nv-1) */
/* ivother = ivmx(iv,(3-iupdown)/2) */
/* tother = 0. */
/* do 5 kkp = 1 , nib(ivother,ibar) */
/* if (abs(tother-tnow) .lt. tol) go to 6 */
/* tother = tother+nodur(ivother,kkp) */
/* 5 continue */
/* c */
/* c If here, then no note starts in other voice at same time, so set default */
/* c */
/* levother = -iupdown*50 */
/* go to 7 */
/* 6 continue */
/* c */
/* c If here, have just identified a simultaneous note or rest in other voice */
/* c */
/* if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it */
/* levother = nolev(ivother,kkp)-ncmid(iv,ip)+4 */
/* else */
/* if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then */
/* c */
/* c Rest in other voice has same duration, get out (so defualt spacing is used) */
/* c */
/* go to 2 */
/* end if */
/* levother = -iupdown*50 */
/* end if */
/* 7 continue */
/* indxr = log2(nodur(ivx,ip))+1 */
/* if (iupdown .lt. 0) then */
/* levtop = levtopr(indxr) */
/* iraise1 = levother-levtop-3 ! Based on other note */
/* iraise2 = levnext-levtop ! Based on following note */
/* if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2 */
/* iraise = min(iraise1,iraise2) */
/* if (mod(iraise+50,2).eq.1 .and. */
/* * iraise+levtop.gt.-1) iraise = iraise-1 */
/* else */
/* levbot = levbotr(indxr) */
/* iraise1 = levother-levbot+3 */
/* iraise2 = levnext-levbot */
/* if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1 */
/* iraise = max(iraise1,iraise2) */
/* if (mod(iraise+50,2).eq.1 .and. */
/* * iraise+levbot.le.9) iraise = iraise-1 */
/* end if */
/* nolev(ivx,ip) = 100+iraise */
/* The new subroutine call, to replace above code */
chkkbdrests_(&ip, &all_1.iv, &commvl_1.ivx,
all_1.nn, all_1.iornq, all_1.islur,
all_1.irest, all_1.nolev, commvl_1.ivmx,
all_1.nib, &all_1.nv, &all_1.ibar, &tnow,
&comtol_1.tol, all_1.nodur, &c__1,
comkbdrests_1.levtopr,
comkbdrests_1.levbotr, all_1.mult);
}
/* L2: */
/* Write a separate note or rest */
notex_(notexq, &lnote, (ftnlen)79);
}
/* Right offset? This may cause trouble */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],8)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "loff{";
s_cat(ch__15, a__2, i__4, &c__2, (ftnlen)6);
addstr_(ch__15, &c__6, soutq, &lsout, (ftnlen)6, (
ftnlen)80);
} else if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25]
,9)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "roff{";
s_cat(ch__15, a__2, i__4, &c__2, (ftnlen)6);
addstr_(ch__15, &c__6, soutq, &lsout, (ftnlen)6, (
ftnlen)80);
}
if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0 && lnote > 0)
{
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (
ftnlen)80);
}
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],8) ||
bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],9)
) {
addstr_("}", &c__1, soutq, &lsout, (ftnlen)1, (ftnlen)
80);
}
/* Terminate user-defined offsets. Fix format */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],15)
|| bit_test(all_1.irest[commvl_1.ivx + ip * 24 -
25],17)) {
putshft_(&commvl_1.ivx, &c_false, soutq, &lsout, (
ftnlen)80);
}
/* Deal with After- and Way-after-graces. First, if end of bar, compute space */
/* needed since it wasn't done during general ask-checks. If extra space is */
/* rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. */
/* But will still need to add extra space as hardspace. */
if (ip == all_1.nn[commvl_1.ivx - 1] && (bit_test(
all_1.ipl[commvl_1.ivx + ip * 24 - 25],31) ||
bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],
29))) {
i__11 = comgrace_1.ngrace;
for (ig = 1; ig <= i__11; ++ig) {
if (comgrace_1.ipg[ig - 1] == ip &&
comgrace_1.ivg[ig - 1] == commvl_1.ivx) {
goto L78;
}
/* L77: */
}
s_wsle(&io___1053);
do_lio(&c__9, &c__1, "Problem finding grace index "
"at \"do 77\"", (ftnlen)38);
e_wsle();
stop1_();
L78:
/* Get elemskip to end of bar. WON'T WORK IF XTUPS !! */
esk = 0.f;
i__11 = comnsp_2.nb;
for (iib = ib; iib <= i__11; ++iib) {
if (iib == ib) {
itleft = i_nint(&all_1.to[comipl2_1.ipl2[
commvl_1.ivx + ip * 24 - 25] - 1]);
} else {
itleft = i_nint(&tstart[ib]);
}
if (iib < comnsp_2.nb) {
itright = i_nint(&tstart[iib + 1]);
} else {
itright = all_1.lenbar;
}
esk += feon_(&comnsp_2.space[ib - 1]) * (itright
- itleft) / comnsp_2.space[ib - 1];
/* L40: */
}
ptsavail = comask_1.poenom * esk - comask_1.wheadpt;
if (comgrace_1.nng[ig - 1] == 1) {
wgr = spfacs_1.grafac;
} else {
wgr = comgrace_1.nng[ig - 1] * spfacs_1.emgfac;
i__11 = comgrace_1.nng[ig - 1];
for (ing = 1; ing <= i__11; ++ing) {
if (comgrace_1.naccg[comgrace_1.ngstrt[ig - 1]
- 1 + ing - 1] > 0) {
wgr += spfacs_1.acgfac;
}
/* L41: */
}
}
ptgr[ig - 1] = wgr * comask_1.wheadpt;
ptsneed = (wgr + .5f) * comask_1.wheadpt;
ptsndg[commvl_1.ivx - 1] = 0.f;
if (ptsavail < ptsneed) {
ptsndg[commvl_1.ivx - 1] = ptsneed;
eskndg[commvl_1.ivx - 1] = esk;
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 -
25],31)) {
/* Convert GW to GA */
all_1.ipl[commvl_1.ivx + ip * 24 - 25] =
bit_set(bit_clear(all_1.ipl[
commvl_1.ivx + ip * 24 - 25],31),29);
}
}
}
/* Check for GA */
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],29)) {
i__11 = ncmid_(&all_1.iv, &ip);
dograce_(&commvl_1.ivx, &ip, ptgr, soutq, &lsout, &
i__11, &all_1.nacc[commvl_1.ivx + ip * 24 -
25], &ig, &all_1.ipl[commvl_1.ivx + ip * 24 -
25], &c_false, &c_false, &c__0, &c__0, &c__0,
&c__0, &c__0, &c__0, &c_b762, all_1.ulq, &
cominsttrans_1.instno[all_1.iv - 1], (ftnlen)
80, (ftnlen)1);
}
/* 130324 */
/* * .false.,0,0,0,0,0,0,0.,ulq) */
/* Update running time */
tnow += comnsp_2.space[ib - 1];
L10:
;
}
/* Have finished last note in this voice and block */
r__1 = all_1.to[istop[ib] - 1] + comnsp_2.space[ib - 1];
itendb = i_nint(&r__1);
if (all_1.figbass && commvl_1.ivx == 1 || commvl_1.ivx ==
comfig_1.ivxfig2) {
ivf = 1;
if (commvl_1.ivx > 1) {
ivf = 2;
}
L17:
if (all_1.figchk[ivf - 1] && comfig_1.itfig[ivf + (ifig[
ivf - 1] << 1) - 3] < itendb) {
/* There's at least one figure left. offnsk could be <0 */
offnsk = (tnow - comfig_1.itfig[ivf + (ifig[ivf - 1]
<< 1) - 3]) / comnsp_2.space[ib - 1];
putfig_(&ivf, &ifig[ivf - 1], &offnsk, &all_1.figchk[
ivf - 1], soutq, &lsout, (ftnlen)80);
goto L17;
}
}
/* Check for flag, dot, or upstem on last note of bar. */
if (ib == comnsp_2.nb) {
ip = all_1.ipo[comipl2_1.ipl2[commvl_1.ivx + all_1.nn[
commvl_1.ivx - 1] * 24 - 25] - 1];
comnsp_2.flgndv[commvl_1.ivx - 1] = 0.f;
if ((r__1 = all_1.tnote[comipl2_1.ipl2[commvl_1.ivx + ip *
24 - 25] - 1] - comnsp_2.space[ib - 1], dabs(
r__1)) < comtol_1.tol) {
if (comnsp_2.space[ib - 1] < 16.f - comtol_1.tol) {
/* Note in last space, smaller than a quarter note. */
i__9 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[commvl_1.ivx
+ ip * 24 - 25], &i__9, &all_1.islur[
commvl_1.ivx + ip * 24 - 25], &
commvl_1.nvmx[all_1.iv - 1], &
commvl_1.ivx, &all_1.nv);
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24
- 25],0) && *(unsigned char *)&ch__4[0] ==
'u' || isdotted_(all_1.nodur, &
commvl_1.ivx, &ip)) {
/* Upstem non-rest, or dotted */
/* Computing MAX */
i__9 = 1, i__11 = numbms[commvl_1.ivx];
if (numbms[commvl_1.ivx] > 0 && ip ==
all_1.ibm2[commvl_1.ivx + max(i__9,
i__11) * 24 - 25] && ! isdotted_(
all_1.nodur, &commvl_1.ivx, &ip)) {
/* In beam and not dotted, so use smaller space */
comnsp_2.flgndv[commvl_1.ivx - 1] =
spfacs_1.upstmfac;
} else {
comnsp_2.flgndv[commvl_1.ivx - 1] =
spfacs_1.flagfac;
}
}
} else {
/* Last space, nonflagged (no beam) only worry dot or up */
if (isdotted_(all_1.nodur, &commvl_1.ivx, &ip)) {
comnsp_2.flgndv[commvl_1.ivx - 1] =
spfacs_1.flagfac;
} else /* if(complicated condition) */ {
i__9 = ncmid_(&all_1.iv, &ip);
udqq_(ch__4, (ftnlen)1, &all_1.nolev[
commvl_1.ivx + ip * 24 - 25], &i__9, &
all_1.islur[commvl_1.ivx + ip * 24 -
25], &commvl_1.nvmx[all_1.iv - 1], &
commvl_1.ivx, &all_1.nv);
if (all_1.tnote[comipl2_1.ipl2[commvl_1.ivx +
ip * 24 - 25] - 1] < 64.f && *(
unsigned char *)&ch__4[0] == 'u') {
/* Upstem on last note , non-flagged */
comnsp_2.flgndv[commvl_1.ivx - 1] =
spfacs_1.upstmfac;
}
}
}
}
/* Check for right-shifted chordal note */
if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],20))
{
comnsp_2.flgndv[commvl_1.ivx - 1] = spfacs_1.rtshfac;
}
comnsp_2.flgndb = comnsp_2.flgndb || comnsp_2.flgndv[
commvl_1.ivx - 1] > 0.f;
if (commidi_1.ismidi) {
/* For midi, set flags for accidentals on last note of bar. Assume they affect */
/* first note of next bar whether or not tied. */
/* Note has already been done, so next entry into addmidi is 1st in new bar. */
/* First do main note, then chord notes */
/* Gyrations needed to account for multi-bar tied full-bar notes? */
/* c Old old lbacc(icm) = iand(nacc(ivx,ip),7) */
/* New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) */
if ((all_1.nacc[commvl_1.ivx + ip * 24 - 25] & 7) > 0)
{
/* Explicit accidental on last main note in bar */
i__9 = comslm_1.naccbl[icm];
for (kacc = 1; kacc <= i__9; ++kacc) {
if (comslm_1.laccbl[icm + kacc * 25 - 25] ==
all_1.nolev[commvl_1.ivx + ip * 24 -
25]) {
goto L56;
}
/* L55: */
}
++comslm_1.naccbl[icm];
comslm_1.laccbl[icm + comslm_1.naccbl[icm] * 25 -
25] = all_1.nolev[commvl_1.ivx + ip * 24
- 25];
i__9 = all_1.nacc[commvl_1.ivx + ip * 24 - 25] &
7;
comslm_1.jaccbl[icm + comslm_1.naccbl[icm] * 25 -
25] = iashft_(&i__9);
}
L56:
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],
10) && commidi_1.crdacc) {
i__9 = comtrill_1.icrd2;
for (icrd = comtrill_1.icrd1; icrd <= i__9;
++icrd) {
iacc = igetbits_(&comtrill_1.icrdat[icrd - 1],
&c__3, &c__20);
if (iacc > 0) {
/* Explicit accidental on chord note at end of bar */
nolevc = igetbits_(&comtrill_1.icrdat[
icrd - 1], &c__7, &c__12);
i__11 = comslm_1.naccbl[icm];
for (kacc = 1; kacc <= i__11; ++kacc) {
if (comslm_1.laccbl[icm + kacc * 25 -
25] == nolevc) {
goto L59;
}
/* L58: */
}
++comslm_1.naccbl[icm];
comslm_1.laccbl[icm + comslm_1.naccbl[icm]
* 25 - 25] = nolevc;
comslm_1.jaccbl[icm + comslm_1.naccbl[icm]
* 25 - 25] = iashft_(&iacc);
}
L59:
/* L57: */
;
}
}
/* if (lbacc(icm).eq.0 .and. accb4(icm)) then */
i__9 = commidi_1.naccim[icm];
for (kacc = 1; kacc <= i__9; ++kacc) {
/* If naccim(icm)>0, */
/* possible implicit accidental from earlier in the bar. Check for prior accid */
/* in this bar at relevant note levels, main and chord notes. Only act if no */
/* explicit action from just above. Assuming any accid on last note in bar, */
/* either explicit or implicit, has same effect on 1st note of next bar. */
if (all_1.nolev[commvl_1.ivx + ip * 24 - 25] ==
commidi_1.laccim[icm + kacc * 25 - 25]) {
goto L66;
}
if (bit_test(all_1.ipl[commvl_1.ivx + ip * 24 -
25],10)) {
i__11 = comtrill_1.icrd2;
for (icrd = comtrill_1.icrd1; icrd <= i__11;
++icrd) {
if ((lbit_shift(comtrill_1.icrdat[icrd -
1], (ftnlen)-12) & 127) ==
commidi_1.laccim[icm + kacc * 25
- 25]) {
goto L66;
}
/* L67: */
}
}
goto L65;
L66:
/* So far we know there is a main or chord note at level laccim(icm,kacc). So */
/* it will get a bl-accid if it didn't just already get one. */
i__11 = comslm_1.naccbl[icm];
for (macc = 1; macc <= i__11; ++macc) {
if (comslm_1.laccbl[icm + macc * 25 - 25] ==
commidi_1.laccim[icm + kacc * 25 - 25]
) {
goto L65;
}
/* L68: */
}
++comslm_1.naccbl[icm];
comslm_1.laccbl[icm + comslm_1.naccbl[icm] * 25 -
25] = commidi_1.laccim[icm + kacc * 25 -
25];
comslm_1.jaccbl[icm + comslm_1.naccbl[icm] * 25 -
25] = commidi_1.jaccim[icm + kacc * 25 -
25];
L65:
;
}
}
}
/* L11: */
}
}
/* Close out the notes group */
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 2, a__2[1] = "en";
s_cat(ch__12, a__2, i__4, &c__2, (ftnlen)3);
addstr_(ch__12, &c__3, soutq, &lsout, (ftnlen)3, (ftnlen)80);
if (comlast_1.islast && lsout > 0) {
s_wsfe(&io___1066);
/* Writing concatenation */
i__4[0] = lsout, a__2[0] = soutq;
i__4[1] = 1, a__2[1] = "%";
s_cat(ch__10, a__2, i__4, &c__2, (ftnlen)81);
do_fio(&c__1, ch__10, lsout + 1);
e_wsfe();
}
/* L16: */
}
/* Check for way-after graces at end of bar. We could not link these to notes */
/* as in midbar since there is no note following grace! Also, set flag if */
/* hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. */
isgrace = FALSE_;
i__2 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__2; ++all_1.iv) {
comnsp_2.nvmxsav[all_1.iv - 1] = commvl_1.nvmx[all_1.iv - 1];
i__7 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__7; ++kv) {
comnsp_2.ivmxsav[all_1.iv + kv * 24 - 25] = commvl_1.ivmx[
all_1.iv + kv * 24 - 25];
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
comnsp_2.ptsgnd = 0.f;
if ((bit_test(all_1.ipl[commvl_1.ivx + all_1.nn[commvl_1.ivx - 1]
* 24 - 25],29) || bit_test(all_1.ipl[commvl_1.ivx +
all_1.nn[commvl_1.ivx - 1] * 24 - 25],31)) && ptsndg[
commvl_1.ivx - 1] > 0.f) {
comnsp_2.flgndb = TRUE_;
if (ptsndg[commvl_1.ivx - 1] > comnsp_2.ptsgnd) {
comnsp_2.ptsgnd = ptsndg[commvl_1.ivx - 1];
comnsp_2.eskgnd = eskndg[commvl_1.ivx - 1];
}
}
if (bit_test(all_1.ipl[commvl_1.ivx + all_1.nn[commvl_1.ivx - 1] *
24 - 25],31)) {
/* This voice has a way-after grace here at end of bar */
if (! isgrace) {
/* This is the first one, so set up the string */
isgrace = TRUE_;
ivlast = 1;
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 6, a__2[1] = "znotes";
s_cat(soutq, a__2, i__4, &c__2, (ftnlen)80);
lsout = 7;
}
i__1 = all_1.iv - 1;
for (iiv = ivlast; iiv <= i__1; ++iiv) {
addstr_(all_1.sepsymq + (iiv - 1), &c__1, soutq, &lsout, (
ftnlen)1, (ftnlen)80);
/* L76: */
}
ivlast = all_1.iv;
/* No need to put in 'nextvoice', even if 2 lines/staff */
i__1 = ncmid_(&all_1.iv, &all_1.nn[commvl_1.ivx - 1]);
dograce_(&commvl_1.ivx, &all_1.nn[commvl_1.ivx - 1], ptgr,
soutq, &lsout, &i__1, &all_1.nacc[commvl_1.ivx +
all_1.nn[commvl_1.ivx - 1] * 24 - 25], &ig, &
all_1.ipl[commvl_1.ivx + all_1.nn[commvl_1.ivx - 1] *
24 - 25], &c_true, &c_false, &c__0, &c__0, &c__0, &
c__0, &c__0, &c__0, &c_b762, all_1.ulq, &
cominsttrans_1.instno[all_1.iv - 1], (ftnlen)80, (
ftnlen)1);
/* 130324 */
/* * .false.,0,0,0,0,0,0,0.,ulq) */
}
/* L75: */
}
}
if (isgrace) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 3, a__2[1] = "en%";
s_cat(ch__17, a__2, i__4, &c__2, (ftnlen)4);
addstr_(ch__17, &c__4, soutq, &lsout, (ftnlen)4, (ftnlen)80);
if (comlast_1.islast && lsout > 0) {
s_wsfe(&io___1069);
do_fio(&c__1, soutq, lsout);
e_wsfe();
}
}
lsout = 0;
/* Write multibar rest. Assuming nv = 1 and do not worry about cwbrest */
/* This has to be the only use of atnextbar */
/* if (ibar .eq. ibarmbr) then */
if (all_1.ibar == comgrace_1.ibarmbr && comlast_1.islast) {
/* call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// */
/* * 'mbrest{',30,soutq,lsout) */
/* ndig = int(alog10(mbrest+.01))+1 */
/* write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest */
/* lsout = lsout+ndig */
/* call addstr('}{',2,soutq,lsout) */
/* mtrspc = .5+xb4mbr */
/* xb4mbr = 0. */
/* if (mtrspc .eq. 0) then */
/* ndig = 1 */
/* else */
/* ndig = int(alog10(mtrspc+.01))+1 */
/* end if */
/* write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc */
/* lsout = lsout+ndig */
/* call addstr('}0'//sq//'en}%',7,soutq,lsout) */
/* if (islast) write(11,'(a)')soutq(1:lsout) */
/* lsout = 0 */
/* ndig = int(alog10(mbrest-1+.01))+1 */
/* if (mbrest.eq.1) ndig=1 */
/* if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') */
/* * sq//'advance'//sq//'barno',mbrest-1,'%' */
/* ++ */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "def";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 10, a__1[3] = "atnextbar{";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 6, a__1[5] = "znotes";
s_cat(soutq, a__1, i__3, &c__6, (ftnlen)80);
lsout = 22;
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 6, a__2[1] = "mbrest";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 7;
istring_(&comgrace_1.mbrest, noteq, &len, (ftnlen)8);
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = len, a__2[1] = noteq;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += len;
mtrspc = comgrace_1.xb4mbr + .5f;
comgrace_1.xb4mbr = 0.f;
istring_(&mtrspc, noteq, &len, (ftnlen)8);
/* Writing concatenation */
i__6[0] = lnote, a__4[0] = notexq;
i__6[1] = len, a__4[1] = noteq;
i__6[2] = 1, a__4[2] = "0";
s_cat(notexq, a__4, i__6, &c__3, (ftnlen)79);
lnote = lnote + len + 1;
i__7 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__7; ++all_1.iv) {
addstr_(notexq, &lnote, soutq, &lsout, (ftnlen)79, (ftnlen)80);
if (all_1.iv < all_1.nv) {
addstr_(all_1.sepsymq + (all_1.iv - 1), &c__1, soutq, &lsout,
(ftnlen)1, (ftnlen)80);
}
/* L62: */
}
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 4, a__2[1] = "en}%";
s_cat(ch__16, a__2, i__4, &c__2, (ftnlen)5);
addstr_(ch__16, &c__5, soutq, &lsout, (ftnlen)5, (ftnlen)80);
s_wsfe(&io___1072);
do_fio(&c__1, soutq, lsout);
e_wsfe();
lsout = 0;
if (comgrace_1.mbrest > 1) {
r__1 = comgrace_1.mbrest - 1 + .01f;
ndig = (integer) r_lg10(&r__1) + 1;
ci__1.cierr = 0;
ci__1.ciunit = 11;
/* Writing concatenation */
i__6[0] = 6, a__4[0] = "(a14,i";
i__7 = ndig + 48;
chax_(ch__4, (ftnlen)1, &i__7);
i__6[1] = 1, a__4[1] = ch__4;
i__6[2] = 4, a__4[2] = ",a1)";
ci__1.cifmt = (s_cat(ch__7, a__4, i__6, &c__3, (ftnlen)11), ch__7)
;
s_wsfe(&ci__1);
/* Writing concatenation */
i__8[0] = 1, a__5[0] = all_1.sq;
i__8[1] = 7, a__5[1] = "advance";
i__8[2] = 1, a__5[2] = all_1.sq;
i__8[3] = 5, a__5[3] = "barno";
s_cat(ch__18, a__5, i__8, &c__4, (ftnlen)14);
do_fio(&c__1, ch__18, (ftnlen)14);
i__2 = comgrace_1.mbrest - 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "%", (ftnlen)1);
e_wsfe();
}
} else if (iscwr) {
/* Centered whole-bar rests */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "def";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 10, a__1[3] = "atnextbar{";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 6, a__1[5] = "znotes";
s_cat(ch__19, a__1, i__3, &c__6, (ftnlen)22);
addstr_(ch__19, &c__22, soutq, &lsout, (ftnlen)22, (ftnlen)80);
i__7 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__7; ++all_1.iv) {
lnote = 0;
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
if (cwrest[commvl_1.ivx]) {
if (lnote == 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 10, a__2[1] = "centerbar{";
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote = 11;
}
if (! comcwrf_1.cwrferm[commvl_1.ivx - 1]) {
if (lcwr[commvl_1.ivx - 1] >= 11 && *(unsigned char *)
&cwrq[(commvl_1.ivx - 1) * 79 + 10] != 'p') {
/* Kluge to use new definitions for centered, stacked rests */
if (s_cmp(cwrq + ((commvl_1.ivx - 1) * 79 + 1),
"liftpause", (ftnlen)9, (ftnlen)9) == 0 ||
s_cmp(cwrq + ((commvl_1.ivx - 1) * 79 +
1), "liftPAuse", (ftnlen)9, (ftnlen)9) ==
0) {
*(unsigned char *)&cwrq[(commvl_1.ivx - 1) *
79 + 9] = 'c';
}
}
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = lcwr[commvl_1.ivx - 1], a__2[1] = cwrq + (
commvl_1.ivx - 1) * 79;
s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
lnote += lcwr[commvl_1.ivx - 1];
} else {
/* Fermata on centered rest. Will need to fix up level. */
/* 12/6/07 shift it left so it's centered over rest */
/* notexq = notexq(1:lnote) */
/* * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) */
/* lnote = lnote+11+lcwr(ivx) */
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = all_1.sq;
i__3[2] = 13, a__1[2] = "loffset{.39}{";
i__3[3] = 1, a__1[3] = all_1.sq;
i__3[4] = 11, a__1[4] = "fermataup7}";
i__3[5] = lcwr[commvl_1.ivx - 1], a__1[5] = cwrq + (
commvl_1.ivx - 1) * 79;
s_cat(notexq, a__1, i__3, &c__6, (ftnlen)79);
lnote = lnote + 26 + lcwr[commvl_1.ivx - 1];
comcwrf_1.cwrferm[commvl_1.ivx - 1] = FALSE_;
}
}
/* L61: */
}
if (lnote > 0) {
/* Writing concatenation */
i__4[0] = lnote, a__2[0] = notexq;
i__4[1] = 1, a__2[1] = "}";
s_cat(ch__1, a__2, i__4, &c__2, (ftnlen)80);
i__2 = lnote + 1;
addstr_(ch__1, &i__2, soutq, &lsout, lnote + 1, (ftnlen)80);
}
if (all_1.iv != all_1.nv) {
addstr_(all_1.sepsymq + (all_1.iv - 1), &c__1, soutq, &lsout,
(ftnlen)1, (ftnlen)80);
}
/* L60: */
}
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 3, a__2[1] = "en}";
s_cat(ch__17, a__2, i__4, &c__2, (ftnlen)4);
addstr_(ch__17, &c__4, soutq, &lsout, (ftnlen)4, (ftnlen)80);
if (comlast_1.islast && lsout > 0) {
s_wsfe(&io___1074);
/* Writing concatenation */
i__4[0] = lsout, a__2[0] = soutq;
i__4[1] = 1, a__2[1] = "%";
s_cat(ch__10, a__2, i__4, &c__2, (ftnlen)81);
do_fio(&c__1, ch__10, lsout + 1);
e_wsfe();
}
}
/* End of block for centered whole-bar rests and multi-bar rests */
/* If at end of block, save durations of last notes in bar, for possible use */
/* if clef changes at start of next bar */
if (all_1.ibar == all_1.nbars) {
i__7 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__7; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
/* prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) */
comnsp_2.prevtn[commvl_1.ivx - 1] = all_1.tnote[
comipl2_1.ipl2[commvl_1.ivx + all_1.nn[commvl_1.ivx -
1] * 24 - 25] - 1];
/* L63: */
}
}
}
/* Update time for midi. This is only used for the event track */
if (commidi_1.ismidi) {
comevent_1.miditime += all_1.lenbar * 15;
/* If pickup, write the real time signature to the event track. Cannot use */
/* mtrnuml since it was reset to 0, have to recompute it */
if (all_1.lenb0 == all_1.lenbar) {
i__2 = all_1.mtrdenl * all_1.lenb1 / 64;
midievent_("m", &i__2, &all_1.mtrdenl, (ftnlen)1);
}
}
return 0;
} /* make2bar_ */
/* Subroutine */ int makeabar_(void)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Builtin functions */
integer i_nint(real *);
/* Local variables */
extern /* Subroutine */ int catspace_(real *, real *, integer *);
static real elsperns;
extern doublereal getsquez_(integer *, integer *, real *, real *, real *);
static integer ib, in, kv, cnn[24];
static real xit[24];
static integer ilnc;
static real tmin;
static integer nnsk, ntot;
extern doublereal f1eon_(real *);
extern /* Subroutine */ int stop1_(void);
static real space[80];
extern doublereal fnote_(integer *, integer *, integer *, integer *);
static real tminn, tnote[600];
static integer istop[80];
static real squez[80];
static integer istart[80];
extern /* Subroutine */ int printl_(char *, ftnlen);
static integer ivnext;
static real tstart[80], xsquez;
/* On input, have pseudo-durations in nodur(ivx,ip). Not real durations for */
/* xtups, since only last note of xtup gets non-zero nodur, which */
/* corresponds to single note of full length of xtup. */
/* In this subroutine we make an ordered list of all notes in all voices. */
/* ilnc = list note counter */
/* ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. */
/* to(ilnc) = real start time of note in PMX-units (64=whole note) */
/* tno(ilnc) = time to next event in the bar. */
/* tnote(ilnc) = actual duration of note */
/* Then run thru list, grouping consecutive notes into \notes groups ib. */
/* space(ib) = real time unit for the \notes group */
/* squez(ib) = factor on space to get effective space. This will be 1 if */
/* there is a note exactly spanning each interval of space, and */
/* <1 if not. */
/* Details: let eon = elemskips per noteskip (like length). Basic formula is */
/* eon = sqrt(space/2.) */
/* If tgovern >= space, then */
/* eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). */
/* Time needed to give this eon using basic formula is */
/* teq = space**2/tgovern */
/* Factor on space to get teq is */
/* squez(ib) = space/tgovern */
/* The eon for each ib can then be computed based on time of space*squez. */
/* Iff squez = 1, there is a note spanning every increment in the \notes group. */
/* tnminb = minimum time span in the bar for increments spanned by notes, */
/* i.e., with squez=1. Use after parsing into line to decide if */
/* spacing needs to be "flattened" among notes groups. */
linecom_1.elskb = 0.f;
linecom_1.tnminb[c1omnotes_1.ibarcnt - 1] = 1e3f;
i__1 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__1; ++a1ll_2.iv) {
i__2 = c1ommvl_1.nvmx[a1ll_2.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
c1ommvl_1.ivx = c1ommvl_1.ivmx[a1ll_2.iv + kv * 24 - 25];
if (a1ll_2.ibar > 1) {
a1ll_2.nn[c1ommvl_1.ivx - 1] = a1ll_2.nib[c1ommvl_1.ivx +
a1ll_2.ibar * 24 - 25] - a1ll_2.nib[c1ommvl_1.ivx + (
a1ll_2.ibar - 1) * 24 - 25];
} else {
a1ll_2.nn[c1ommvl_1.ivx - 1] = a1ll_2.nib[c1ommvl_1.ivx +
a1ll_2.ibar * 24 - 25];
}
/* L1: */
}
}
/* initialize list note counter, time(iv), curr. note(iv) */
ilnc = 1;
i__2 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__2; ++a1ll_2.iv) {
i__1 = c1ommvl_1.nvmx[a1ll_2.iv - 1];
for (kv = 1; kv <= i__1; ++kv) {
c1ommvl_1.ivx = c1ommvl_1.ivmx[a1ll_2.iv + kv * 24 - 25];
cnn[c1ommvl_1.ivx - 1] = 1;
a1ll_2.ivxo[ilnc - 1] = c1ommvl_1.ivx;
a1ll_2.ipo[ilnc - 1] = 1;
a1ll_2.to[ilnc - 1] = 0.f;
tnote[ilnc - 1] = fnote_(a1ll_2.nodur, &c1ommvl_1.ivx, &c__1,
c1ommvl_1.nacc);
xit[c1ommvl_1.ivx - 1] = tnote[ilnc - 1];
if ((r__1 = xit[c1ommvl_1.ivx - 1] - a1ll_2.lenbar, dabs(r__1)) <
comtol_1.tol) {
xit[c1ommvl_1.ivx - 1] = 1e3f;
}
++ilnc;
/* L4: */
}
}
/* Build the list */
L5:
/* Determine which voice comes next from end of notes done so far. */
/* tmin is the earliest ending time of notes done so far */
tmin = 1e3f;
i__1 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__1; ++a1ll_2.iv) {
i__2 = c1ommvl_1.nvmx[a1ll_2.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
c1ommvl_1.ivx = c1ommvl_1.ivmx[a1ll_2.iv + kv * 24 - 25];
/* Computing MIN */
r__1 = tmin, r__2 = xit[c1ommvl_1.ivx - 1];
tminn = dmin(r__1,r__2);
if (tminn < tmin) {
tmin = tminn;
ivnext = c1ommvl_1.ivx;
}
/* L6: */
}
}
if (tmin > 999.f) {
goto L7;
}
a1ll_2.ivxo[ilnc - 1] = ivnext;
++cnn[ivnext - 1];
a1ll_2.ipo[ilnc - 1] = cnn[ivnext - 1];
a1ll_2.to[ilnc - 1] = tmin;
/* Check if this voice is done */
tnote[ilnc - 1] = fnote_(a1ll_2.nodur, &ivnext, &cnn[ivnext - 1],
c1ommvl_1.nacc);
if (cnn[ivnext - 1] == a1ll_2.nn[ivnext - 1]) {
xit[ivnext - 1] = 1e3f;
} else {
xit[ivnext - 1] += tnote[ilnc - 1];
}
++ilnc;
goto L5;
L7:
ntot = ilnc - 1;
if (ntot > 600) {
printl_(" ", (ftnlen)1);
printl_("Cannot have more than 600 notes per bar, stopping", (ftnlen)
49);
stop1_();
}
i__2 = ntot - 1;
for (in = 1; in <= i__2; ++in) {
a1ll_2.tno[in - 1] = a1ll_2.to[in] - a1ll_2.to[in - 1];
/* L8: */
}
a1ll_2.tno[ntot - 1] = fnote_(a1ll_2.nodur, &a1ll_2.ivxo[ntot - 1], &
a1ll_2.ipo[ntot - 1], c1ommvl_1.nacc);
tnote[ntot - 1] = a1ll_2.tno[ntot - 1];
/* Debug writes */
/* write(*,'()') */
/* write(*,'(16i5)')(ivxo(in),in=1,ntot) */
/* write(*,'(16i5)')(ipo(in),in=1,ntot) */
/* write(*,'(16f5.1)')(to(in),in=1,ntot) */
/* write(*,'(16f5.1)')(tno(in),in=1,ntot) */
/* write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) */
/* write(*,'(16f5.1)')(tnote(in),in=1,ntot) */
/* Done w/ list. Initialize loop for building note blocks: */
ib = 1;
istart[0] = 1;
space[0] = 0.f;
in = 1;
/* Start the loop */
L9:
if (in == ntot) {
if (space[ib - 1] < comtol_1.tol) {
space[ib - 1] = a1ll_2.tno[in - 1];
/* Last gap in bar is spanned by a note, so cannot need a squeeze. */
squez[ib - 1] = 1.f;
}
istop[ib - 1] = ntot;
/* From here flow out of this if block and into block-setup */
} else if (space[ib - 1] < comtol_1.tol) {
/* space hasn't been set yet, so tentatively set: */
space[ib - 1] = a1ll_2.tno[in - 1];
if (space[ib - 1] < comtol_1.tol) {
++in;
} else {
/* Tentative space tno(in) is non-zero. Set squez, which will be kept (since */
/* it is a unique property of the particular increment starting here) : */
squez[ib - 1] = getsquez_(&in, &ntot, &space[ib - 1], tnote,
a1ll_2.to);
istop[ib - 1] = in;
}
goto L9;
} else if (a1ll_2.tno[in] < comtol_1.tol) {
/* This is not the last note in the space, so */
++in;
goto L9;
} else if ((r__1 = a1ll_2.tno[in] - space[ib - 1], dabs(r__1)) <
comtol_1.tol) {
/* Next increment has same space. Does it have same squez? */
i__2 = in + 1;
xsquez = getsquez_(&i__2, &ntot, &space[ib - 1], tnote, a1ll_2.to);
/* If it does have the same squez, loop, otherwise flow out */
if ((r__1 = xsquez - squez[ib - 1], dabs(r__1)) < comtol_1.tol) {
/* Keep spacing the same, update tentative stop point */
++in;
istop[ib - 1] = in;
goto L9;
}
}
/* At this point istart, istop, space, and squez are good, so close out block */
tstart[ib - 1] = a1ll_2.to[istart[ib - 1] - 1];
/* Compute elemskips assuming no flattening to increase min space. The formula */
/* is only correct if f1eon(t) = sqrt(t/2); more generally (after possible */
/* flattening in pmxb), elsperns = squez*feon(space/squez) */
r__1 = space[ib - 1] * squez[ib - 1];
elsperns = f1eon_(&r__1);
if (istop[ib - 1] == ntot) {
r__1 = (a1ll_2.lenbar - tstart[ib - 1]) / space[ib - 1];
nnsk = i_nint(&r__1);
} else {
r__1 = (a1ll_2.to[istop[ib - 1]] - tstart[ib - 1]) / space[ib - 1];
nnsk = i_nint(&r__1);
}
linecom_1.elskb += elsperns * nnsk;
if (c1omnotes_1.nptr[c1omnotes_1.ibarcnt] > c1omnotes_1.nptr[
c1omnotes_1.ibarcnt - 1]) {
catspace_(&space[ib - 1], &squez[ib - 1], &nnsk);
} else {
/* This is the first entry for this bar */
c1omnotes_1.nnpd[c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1] - 1] =
nnsk;
c1omnotes_1.durb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1] - 1] =
space[ib - 1];
c1omnotes_1.sqzb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1] - 1] =
squez[ib - 1];
++c1omnotes_1.nptr[c1omnotes_1.ibarcnt];
}
/* Update minimum space spanned by a note */
if ((r__1 = squez[ib - 1] - 1, dabs(r__1)) < comtol_1.tol) {
/* Computing MIN */
r__2 = linecom_1.tnminb[c1omnotes_1.ibarcnt - 1], r__3 = space[ib - 1]
;
linecom_1.tnminb[c1omnotes_1.ibarcnt - 1] = dmin(r__2,r__3);
}
if (istop[ib - 1] == ntot) {
goto L15;
}
/* End of spatial accounting for now */
++ib;
istart[ib - 1] = istop[ib - 2] + 1;
in = istart[ib - 1];
/* Set tentative block space for new block */
space[ib - 1] = a1ll_2.tno[in - 1];
if (space[ib - 1] > comtol_1.tol) {
squez[ib - 1] = getsquez_(&in, &ntot, &space[ib - 1], tnote,
a1ll_2.to);
}
istop[ib - 1] = in;
goto L9;
L15:
/* nb = ib */
/* Debug writes */
/* write(*,'(16i5)')(istart(ib),ib=1,nb) */
/* write(*,'(16i5)')(istop(ib),ib=1,nb) */
/* write(*,'(16f5.1)')(space(ib),ib=1,nb) */
/* write(*,'(16f5.1)')(squez(ib),ib=1,nb) */
return 0;
} /* makeabar_ */
/* Subroutine */ int midievent_(char *typeq, integer *in1, integer *in2,
ftnlen typeq_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer lbit_shift(integer, integer), i_nint(real *), s_wsle(cilist *),
do_lio(integer *, integer *, char *, ftnlen), e_wsle(void);
/* Local variables */
static integer i__;
extern integer isetvarlen_(integer *, integer *), log2_(integer *);
static integer idur;
extern /* Subroutine */ int stop1_(void);
static integer nbytes, misperq;
/* Fortran I/O blocks */
static cilist io___1098 = { 0, 6, 0, 0, 0 };
/* We now store "conductor" events in mmidi(numchan,.), and count bytes */
/* with imidi(numchan) */
i__1 = comevent_1.miditime - comevent_1.lasttime;
idur = isetvarlen_(&i__1, &nbytes);
commidi_1.imidi[commidi_1.numchan] = commidi_1.imidi[commidi_1.numchan] +
nbytes + 1;
i__1 = nbytes;
for (i__ = 1; i__ <= i__1; ++i__) {
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] - i__) * 25 - 25] = (shortint) (idur % 256)
;
idur = lbit_shift(idur, (ftnlen)-8);
/* L1: */
}
commidi_1.mmidi[commidi_1.numchan + commidi_1.imidi[commidi_1.numchan] *
25 - 25] = 255;
if (*(unsigned char *)typeq == 't') {
/* Tempo event. in1 = quarters per minute (integer) */
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 1) * 25 - 25] = 81;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 2) * 25 - 25] = 3;
r__1 = 6e7f / *in1;
misperq = i_nint(&r__1);
for (i__ = 1; i__ <= 3; ++i__) {
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 6 - i__) * 25 - 25] = (shortint) (
misperq % 256);
misperq = lbit_shift(misperq, (ftnlen)-8);
/* L2: */
}
commidi_1.imidi[commidi_1.numchan] += 5;
} else if (*(unsigned char *)typeq == 'm') {
/* Meter event. in1=numerator, in2=denom (power of 2) */
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 1) * 25 - 25] = 88;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 2) * 25 - 25] = 4;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 3) * 25 - 25] = (shortint) (*in1);
if (*in2 > 0) {
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 4) * 25 - 25] = (shortint) log2_(in2)
;
} else {
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 4) * 25 - 25] = 0;
}
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 5) * 25 - 25] = 24;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 6) * 25 - 25] = 8;
commidi_1.imidi[commidi_1.numchan] += 6;
} else if (*(unsigned char *)typeq == 'k') {
/* Keychange event. in1 = isig */
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 1) * 25 - 25] = 89;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 2) * 25 - 25] = 2;
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 3) * 25 - 25] = (shortint) ((*in1 + 256)
% 256);
commidi_1.mmidi[commidi_1.numchan + (commidi_1.imidi[
commidi_1.numchan] + 4) * 25 - 25] = 0;
commidi_1.imidi[commidi_1.numchan] += 4;
} else {
s_wsle(&io___1098);
do_lio(&c__9, &c__1, "Program flameout in midievent", (ftnlen)29);
e_wsle();
stop1_();
}
comevent_1.lasttime = comevent_1.miditime;
return 0;
} /* midievent_ */
/* Subroutine */ int moveln_(integer *iuin, integer *iuout, logical *done)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
extern integer llen_(char *, integer *, ftnlen);
static char outq[129];
static integer lenout;
/* Fortran I/O blocks */
static cilist io___1099 = { 0, 0, 1, "(a)", 0 };
static cilist io___1102 = { 0, 0, 0, "(a)", 0 };
*done = FALSE_;
io___1099.ciunit = *iuin;
i__1 = s_rsfe(&io___1099);
if (i__1 != 0) {
goto L1;
}
i__1 = do_fio(&c__1, outq, (ftnlen)129);
if (i__1 != 0) {
goto L1;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L1;
}
lenout = llen_(outq, &c__129, (ftnlen)129);
io___1102.ciunit = *iuout;
s_wsfe(&io___1102);
do_fio(&c__1, outq, lenout);
e_wsfe();
return 0;
L1:
*done = TRUE_;
return 0;
} /* moveln_ */
/* Subroutine */ int mrec1_(char *lineq, integer *iccount, integer *ndxm,
ftnlen lineq_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer ntindex_(char *, char *, integer *, ftnlen, ftnlen);
/* This is called when (a) macro recording is just starting and */
/* (b) at the start of a new line, if recording is on */
if (! commac_1.mrecord) {
/* Starting the macro */
c1ommac_1.ip1mac[commac_1.macnum - 1] = inbuff_1.ipbuf -
inbuff_1.lbuf[inbuff_1.ilbuf - 2] + *iccount;
c1ommac_1.il1mac[commac_1.macnum - 1] = inbuff_1.ilbuf - 1;
c1ommac_1.ic1mac[commac_1.macnum - 1] = *iccount;
commac_1.mrecord = TRUE_;
}
if (*iccount < 128) {
i__1 = *iccount;
*ndxm = i_indx(lineq + i__1, "M", 128 - i__1, (ftnlen)1);
if (*ndxm > 0) {
i__1 = *iccount;
i__2 = 128 - *iccount;
*ndxm = ntindex_(lineq + i__1, "M", &i__2, 128 - i__1, (ftnlen)1);
}
if (*ndxm > 0) {
/* This line ends the macro. */
c1ommac_1.ip2mac[commac_1.macnum - 1] = inbuff_1.ipbuf -
inbuff_1.lbuf[inbuff_1.ilbuf - 2] + *iccount + *ndxm;
c1ommac_1.il2mac[commac_1.macnum - 1] = inbuff_1.ilbuf - 1;
commac_1.mrecord = FALSE_;
}
}
return 0;
} /* mrec1_ */
integer ncmid_(integer *iv, integer *ip)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer icc;
static real xtime;
/* Fortran I/O blocks */
static cilist io___1105 = { 0, 6, 0, 0, 0 };
if (comcc_1.ncc[*iv - 1] == 1) {
ret_val = comcc_1.ncmidcc[*iv - 1];
} else {
xtime = all_2.to[comipl2_1.ipl2[commvl_1.ivx + *ip * 24 - 25] - 1];
for (icc = comcc_1.ncc[*iv - 1]; icc >= 1; --icc) {
if (xtime > comcc_1.tcc[*iv + icc * 24 - 25] - comtol_1.tol) {
ret_val = comcc_1.ncmidcc[*iv + icc * 24 - 25];
return ret_val;
}
/* L1: */
}
s_wsle(&io___1105);
do_lio(&c__9, &c__1, "Problem in ncmid()", (ftnlen)18);
e_wsle();
s_stop("", (ftnlen)0);
}
return ret_val;
} /* ncmid_ */
integer ncmidf_(char *clefq, ftnlen clefq_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Return middle line of a clef */
/* if (clefq.eq.'t' .or. clefq.eq.'0') then */
/* ncmidf = 35 */
/* else if (clefq.eq.'s' .or. clefq.eq.'1') then */
/* ncmidf = 33 */
/* else if (clefq.eq.'m' .or. clefq.eq.'2') then */
/* ncmidf = 31 */
/* else if (clefq.eq.'a' .or. clefq.eq.'3') then */
/* ncmidf = 29 */
/* else if (clefq.eq.'n' .or. clefq.eq.'4') then */
/* ncmidf = 27 */
/* else if (clefq.eq.'r' .or. clefq.eq.'5') then */
/* ncmidf = 25 */
/* else if (clefq.eq.'f' .or. clefq.eq.'7') then */
/* ncmidf = 37 */
/* else */
/* ncmidf = 23 */
/* end if */
ret_val = (i_indx(" b6r5n4a3m2s1t0f7", clefq, (ftnlen)17, (ftnlen)1) / 2
<< 1) + 21;
return ret_val;
} /* ncmidf_ */
/* Subroutine */ int newvoice_(integer *jv, char *clefq, logical *change,
ftnlen clefq_len)
{
static integer j;
extern integer ncmidf_(char *, ftnlen);
commvl_1.nvmx[*jv - 1] = 1;
commvl_1.ivmx[*jv - 1] = *jv;
all_1.itsofar[*jv - 1] = 0;
all_1.nnl[*jv - 1] = 0;
comfb_1.nfb[*jv - 1] = 0;
if (all_1.firstgulp || *change) {
comcc_1.ncmidcc[*jv - 1] = ncmidf_(clefq, (ftnlen)1);
} else {
comcc_1.ncmidcc[*jv - 1] = comcc_1.ncmidcc[*jv + comcc_1.ncc[*jv - 1]
* 24 - 25];
}
comcc_1.tcc[*jv - 1] = 0.f;
comcc_1.ncc[*jv - 1] = 1;
comudsp_1.nudoff[*jv - 1] = 0;
comcc_1.ndotmv[*jv - 1] = 0;
for (j = 1; j <= 200; ++j) {
all_1.irest[*jv + j * 24 - 25] = 0;
all_1.islur[*jv + j * 24 - 25] = 0;
all_1.ipl[*jv + j * 24 - 25] = 0;
all_1.nacc[*jv + j * 24 - 25] = 0;
all_1.iornq[*jv + j * 24 - 1] = 0;
all_1.mult[*jv + j * 24 - 25] = 0;
if (*jv <= 2) {
all_1.isfig[*jv + (j << 1) - 3] = FALSE_;
}
/* L5: */
}
return 0;
} /* newvoice_ */
/* Subroutine */ int notefq_(char *noteq, integer *lnote, integer *nolev,
integer *ncmid, ftnlen noteq_len)
{
/* System generated locals */
integer i__1;
char ch__1[1], ch__2[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
static integer nupfroma, i__;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer iname, ioctup;
static char noteqt[1];
extern /* Character */ VOID upcaseq_(char *, ftnlen, char *, ftnlen);
/* Returns name of note level with octave transpositions, updates noctup. */
nupfroma = (*nolev + 1) % 7;
iname = nupfroma + 97;
ioctup = (*nolev + 1) / 7 - 4;
chax_(ch__1, (ftnlen)1, &iname);
*(unsigned char *)noteqt = *(unsigned char *)&ch__1[0];
if (*ncmid == 23) {
upcaseq_(ch__1, (ftnlen)1, noteqt, (ftnlen)1);
*(unsigned char *)noteqt = *(unsigned char *)&ch__1[0];
}
if (ioctup == comoct_1.noctup) {
s_copy(noteq, noteqt, (ftnlen)8, (ftnlen)1);
*lnote = 1;
/* Must ALWAYS check if lnote=1 for use with functions requiring a blank */
} else if (ioctup > comoct_1.noctup) {
/* Raise octave. Encase in {} */
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = noteq;
ici__1.icifmt = "(8a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
i__1 = ioctup - 1;
for (i__ = comoct_1.noctup; i__ <= i__1; ++i__) {
chax_(ch__2, (ftnlen)1, &c__39);
*(unsigned char *)&ch__1[0] = *(unsigned char *)&ch__2[0];
do_fio(&c__1, ch__1, (ftnlen)1);
}
do_fio(&c__1, noteqt, (ftnlen)1);
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
*lnote = ioctup + 3 - comoct_1.noctup;
comoct_1.noctup = ioctup;
} else {
/* Lower octave */
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = noteq;
ici__1.icifmt = "(8a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
i__1 = comoct_1.noctup - 1;
for (i__ = ioctup; i__ <= i__1; ++i__) {
chax_(ch__2, (ftnlen)1, &c__96);
*(unsigned char *)&ch__1[0] = *(unsigned char *)&ch__2[0];
do_fio(&c__1, ch__1, (ftnlen)1);
}
do_fio(&c__1, noteqt, (ftnlen)1);
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
*lnote = comoct_1.noctup + 3 - ioctup;
comoct_1.noctup = ioctup;
}
return 0;
} /* notefq_ */
/* Subroutine */ int notex_(char *notexq, integer *lnote, ftnlen notexq_len)
{
/* System generated locals */
address a__1[4], a__2[3], a__3[5], a__4[2], a__5[8];
integer i__1, i__2, i__3[4], i__4[3], i__5[5], i__6[2], i__7[8];
real r__1;
char ch__1[1];
/* Builtin functions */
integer i_nint(real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, pow_ii(integer *, integer *), i_sign(integer *, integer *);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static real raisedot;
static integer ip;
static char udq[1];
extern integer log2_(integer *);
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static logical even;
static integer nole, ldot, nodu;
static char dotq[4];
extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *,
integer *, integer *, integer *, integer *);
static real zmin;
static char numq[2];
extern integer ncmid_(integer *, integer *);
static real fnole;
static char noteq[8];
static integer lrest;
static char restq[40];
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten;
/* Fortran I/O blocks */
static icilist io___1124 = { 0, noteq, 0, "(i2)", 2, 1 };
static icilist io___1128 = { 0, numq, 0, "(i2)", 2, 1 };
static icilist io___1129 = { 0, noteq+1, 0, "(i2)", 2, 1 };
static icilist io___1130 = { 0, noteq+1, 0, "(i3)", 3, 1 };
/* Returns non-beamed full note name */
ip = all_1.ipo[all_1.jn - 1];
nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25];
/* Check for special situations with 2nds (see precrd) */
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) {
--nole;
} else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) {
++nole;
}
nodu = all_1.nodur[commvl_1.ivx + ip * 24 - 25];
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
i__1 = ncmid_(&all_1.iv, &ip);
udqq_(ch__1, (ftnlen)1, &nole, &i__1, &all_1.islur[commvl_1.ivx + ip *
24 - 25], &commvl_1.nvmx[all_1.iv - 1], &commvl_1.ivx, &
all_1.nv);
*(unsigned char *)udq = *(unsigned char *)&ch__1[0];
}
/* Check figure level */
/* if (figbass .and. isfig(ivx,ip) */
/* * .and. .not.btest(irest(ivx,ip),0)) then */
if (all_1.figbass && ! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],
0) && (commvl_1.ivx == 1 && all_1.isfig[(ip << 1) - 2] ||
commvl_1.ivx == comfig_1.ivxfig2 && all_1.isfig[(ip << 1) - 1])) {
if (*(unsigned char *)udq == 'u' || nodu >= 64) {
/* Upper or no stem, fnole (in noleunits) set by notehead */
fnole = (real) nole;
} else {
/* Lower stem, fnole set by bottom of stem */
fnole = nole - all_1.stemlen;
}
zmin = fnole - ncmid_(&commvl_1.ivx, &ip) + 4;
if (commvl_1.ivx == 1) {
/* Computing MAX */
r__1 = 4 - zmin;
i__1 = all_1.ifigdr[(all_1.iline << 1) - 2], i__2 = i_nint(&r__1);
all_1.ifigdr[(all_1.iline << 1) - 2] = max(i__1,i__2);
} else {
/* Computing MAX */
r__1 = 4 - zmin;
i__1 = all_1.ifigdr[(all_1.iline << 1) - 1], i__2 = i_nint(&r__1);
all_1.ifigdr[(all_1.iline << 1) - 1] = max(i__1,i__2);
}
}
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
i__1 = ncmid_(&all_1.iv, &ip);
notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
if (nodu == 1) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 4, a__1[1] = "cccc";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 6;
} else if (nodu == 2) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "ccc";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 5;
} else if (nodu == 4) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 2, a__1[1] = "cc";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 4;
} else if (nodu == 8) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 1, a__1[1] = "c";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 3;
} else if (nodu == 16) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 1, a__1[1] = "q";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 3;
} else if (nodu == 32) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 1, a__1[1] = "h";
i__3[2] = 1, a__1[2] = udq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 3;
} else if (nodu == 64) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 2, a__2[1] = "wh";
i__4[2] = lnoten, a__2[2] = noteq;
s_cat(notexq, a__2, i__4, &c__3, (ftnlen)79);
*lnote = lnoten + 3;
} else if (nodu == 128) {
/* notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' */
/* lnote = lnoten+10 */
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "breve";
i__4[2] = lnoten, a__2[2] = noteq;
s_cat(notexq, a__2, i__4, &c__3, (ftnlen)79);
*lnote = lnoten + 6;
} else {
s_copy(dotq, "p", (ftnlen)4, (ftnlen)1);
ldot = 1;
if (bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) {
/* Dotted note with ')' ornament */
s_copy(dotq, "m", (ftnlen)4, (ftnlen)1);
} else if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],3)) {
/* Double dot */
s_copy(dotq, "pp", (ftnlen)4, (ftnlen)2);
ldot = 2;
}
if (nodu >= 192) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 5, a__1[1] = "breve";
i__3[2] = ldot, a__1[2] = dotq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 6 + ldot;
} else if (nodu >= 96) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 2, a__1[1] = "wh";
i__3[2] = ldot, a__1[2] = dotq;
i__3[3] = lnoten, a__1[3] = noteq;
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote = lnoten + 3 + ldot;
} else if (nodu >= 48) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 1, a__3[1] = "h";
i__5[2] = 1, a__3[2] = udq;
i__5[3] = ldot, a__3[3] = dotq;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
*lnote = lnoten + 3 + ldot;
} else if (nodu >= 24) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 1, a__3[1] = "q";
i__5[2] = 1, a__3[2] = udq;
i__5[3] = ldot, a__3[3] = dotq;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
*lnote = lnoten + 3 + ldot;
} else if (nodu >= 12) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 1, a__3[1] = "c";
i__5[2] = 1, a__3[2] = udq;
i__5[3] = ldot, a__3[3] = dotq;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
*lnote = lnoten + 3 + ldot;
} else if (nodu >= 6) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 2, a__3[1] = "cc";
i__5[2] = 1, a__3[2] = udq;
i__5[3] = ldot, a__3[3] = dotq;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
*lnote = lnoten + 4 + ldot;
compoi_1.ispoi = TRUE_;
} else {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 3, a__3[1] = "ccc";
i__5[2] = 1, a__3[2] = udq;
i__5[3] = ldot, a__3[3] = dotq;
i__5[4] = lnoten, a__3[4] = noteq;
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
*lnote = lnoten + 5 + ldot;
compoi_1.ispoi = TRUE_;
}
if (*(unsigned char *)dotq == 'm') {
/* Need another call to the note, in case the first one has octave shifts */
if (lnoten == 2) {
/* Writing concatenation */
i__3[0] = *lnote, a__1[0] = notexq;
i__3[1] = 1, a__1[1] = "{";
i__3[2] = 1, a__1[2] = noteq + 1;
i__3[3] = 1, a__1[3] = "}";
s_cat(notexq, a__1, i__3, &c__4, (ftnlen)79);
*lnote += 3;
} else {
i__1 = lnoten - 2;
/* Writing concatenation */
i__6[0] = *lnote, a__4[0] = notexq;
i__6[1] = lnoten - 1 - i__1, a__4[1] = noteq + i__1;
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
++(*lnote);
}
}
}
} else if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],29)) {
/* Blank rest */
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "sk";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 3;
} else {
/* Non-blank rest */
*lnote = 0;
nole = (nole + 20) % 100 - 20;
/* Kluge to get pause symbol for rp: */
if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],19)) {
nodu = 64;
}
if (nodu <= 28) {
/* Normal rest < or = double-dotted quarter */
lrest = 3;
if (nodu > 14) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "qp";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
} else if (nodu > 7) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "ds";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
} else if (nodu > 3) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "qs";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
} else if (nodu > 1) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "hs";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
} else {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 3, a__4[1] = "qqs";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
lrest = 4;
}
/* if (2**log2(nodu) .ne. nodu) then */
/* c */
/* c One or two dots on rest */
/* c */
/* restq = restq(1:3)//'p' */
/* lrest = 4 */
/* if (2*nodu .gt. 3*2**log2(nodu)) then */
/* c */
/* c Double dotted rest */
/* c */
/* restq = restq(1:4)//'p' */
/* lrest = 5 */
/* end if */
/* end if */
s_copy(notexq, restq, (ftnlen)79, (ftnlen)40);
*lnote = lrest;
/* At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. */
if (nole != 0) {
if (abs(nole) < 10) {
i__1 = abs(nole) + 48;
chax_(ch__1, (ftnlen)1, &i__1);
s_copy(noteq, ch__1, (ftnlen)8, (ftnlen)1);
lnoten = 1;
} else {
s_wsfi(&io___1124);
i__1 = abs(nole);
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfi();
lnoten = 2;
}
if (nole > 0) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 5, a__3[1] = "raise";
i__5[2] = lnoten, a__3[2] = noteq;
i__5[3] = 1, a__3[3] = all_1.sq;
i__5[4] = 9, a__3[4] = "internote";
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
} else {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 5, a__3[1] = "lower";
i__5[2] = lnoten, a__3[2] = noteq;
i__5[3] = 1, a__3[3] = all_1.sq;
i__5[4] = 9, a__3[4] = "internote";
s_cat(notexq, a__3, i__5, &c__5, (ftnlen)79);
}
*lnote = lnoten + 16;
/* if (2**log2(nodu) .ne. nodu) then */
/* c */
/* c Have dot in raised rest. must put in hbox! */
/* c */
/* notexq = notexq(1:lnote)//sq//'hbox{' */
/* lnote = lnote+6 */
/* end if */
/* Writing concatenation */
i__6[0] = *lnote, a__4[0] = notexq;
i__6[1] = lrest, a__4[1] = restq;
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote += lrest;
/* if (2**log2(nodu) .ne. nodu) then */
/* notexq = notexq(1:lnote)//'}' */
/* lnote = lnote+1 */
/* end if */
}
i__1 = log2_(&nodu);
if (pow_ii(&c__2, &i__1) != nodu) {
/* Deal with dots (on rests shorter than half rest) */
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 2, a__4[1] = "pt";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
lrest = 3;
i__1 = log2_(&nodu);
if (nodu << 1 > pow_ii(&c__2, &i__1) * 3) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 3, a__4[1] = "ppt";
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
lrest = 4;
}
nole += 4;
raisedot = 0.f;
/* Tweak dot positions for special cases */
even = (nole + 100) % 2 == 0;
/* if (.not.even.and.nodu.gt.8.and. */
/* * (nole.lt.0.or.nole.gt.8)) then */
if (! even && (nole < 0 || nole > 8)) {
raisedot = 1.f;
}
if (nole >= 10 || nole <= -1) {
s_wsfi(&io___1128);
do_fio(&c__1, (char *)&nole, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = lrest, a__1[0] = restq;
i__3[1] = 1, a__1[1] = "{";
i__3[2] = 2, a__1[2] = numq;
i__3[3] = 1, a__1[3] = "}";
s_cat(restq, a__1, i__3, &c__4, (ftnlen)40);
lrest += 4;
} else {
/* Writing concatenation */
i__6[0] = lrest, a__4[0] = restq;
i__1 = nole + 48;
chax_(ch__1, (ftnlen)1, &i__1);
i__6[1] = 1, a__4[1] = ch__1;
s_cat(restq, a__4, i__6, &c__2, (ftnlen)40);
++lrest;
}
if (raisedot > 0.f) {
/* Writing concatenation */
i__7[0] = 1, a__5[0] = all_1.sq;
i__7[1] = 5, a__5[1] = "raise";
i__7[2] = 1, a__5[2] = all_1.sq;
i__7[3] = 9, a__5[3] = "internote";
i__7[4] = 1, a__5[4] = all_1.sq;
i__7[5] = 5, a__5[5] = "hbox{";
i__7[6] = lrest, a__5[6] = restq;
i__7[7] = 1, a__5[7] = "}";
s_cat(restq, a__5, i__7, &c__8, (ftnlen)40);
lrest += 23;
}
/* Writing concatenation */
i__6[0] = lrest, a__4[0] = restq;
i__6[1] = *lnote, a__4[1] = notexq;
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote += lrest;
}
} else {
/* Half rest or longer */
if (nole == 0) {
/* Half or longer rest is not raised or lowered */
if (nodu <= 56) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 6, a__4[1] = "hpause";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 7;
} else if (nodu <= 112) {
if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],
19) || bit_test(all_1.irest[commvl_1.ivx + ip *
24 - 25],25)) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 5, a__4[1] = "pause";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 5, a__4[1] = "pausc";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
}
*lnote = 6;
} else {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 5, a__4[1] = "PAuse";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 6;
}
i__1 = log2_(&nodu);
if (pow_ii(&c__2, &i__1) != nodu) {
/* Dotted rest, hpause or longer */
/* Writing concatenation */
i__6[0] = *lnote, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "p";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
++(*lnote);
i__1 = log2_(&nodu);
if (nodu << 1 > pow_ii(&c__2, &i__1) * 3) {
/* Double dotted long rest */
/* Writing concatenation */
i__6[0] = *lnote, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "p";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
++(*lnote);
}
}
} else {
/* Raised or lowered half or whole rest */
if (nodu == 32) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "lifthpause";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 11;
} else if (nodu == 48) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "lifthpausep";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 12;
} else if (nodu == 56) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 12, a__4[1] = "lifthpausepp";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 13;
} else if (nodu == 64) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 9, a__4[1] = "liftpause";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 10;
} else if (nodu == 96) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "liftpausep";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 11;
} else if (nodu == 112) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "liftpausepp";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 12;
} else if (nodu == 128) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 9, a__4[1] = "liftPAuse";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 10;
} else {
/* Assume dotted double whole rest */
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "liftPAusep";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote = 11;
}
/* Set up height spec */
i__1 = abs(nole) / 2;
nole = i_sign(&i__1, &nole);
if (nole <= 9 && nole >= 0) {
i__1 = nole + 48;
chax_(ch__1, (ftnlen)1, &i__1);
s_copy(noteq, ch__1, (ftnlen)8, (ftnlen)1);
lnoten = 1;
} else {
s_copy(noteq, "{", (ftnlen)8, (ftnlen)1);
if (nole >= -9) {
s_wsfi(&io___1129);
do_fio(&c__1, (char *)&nole, (ftnlen)sizeof(integer));
e_wsfi();
lnoten = 3;
} else {
s_wsfi(&io___1130);
do_fio(&c__1, (char *)&nole, (ftnlen)sizeof(integer));
e_wsfi();
lnoten = 4;
}
/* Writing concatenation */
i__6[0] = lnoten, a__4[0] = noteq;
i__6[1] = 1, a__4[1] = "}";
s_cat(noteq, a__4, i__6, &c__2, (ftnlen)8);
++lnoten;
}
/* Writing concatenation */
i__6[0] = *lnote, a__4[0] = notexq;
i__6[1] = lnoten, a__4[1] = noteq;
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
*lnote += lnoten;
}
}
}
return 0;
} /* notex_ */
integer ntindex_(char *line, char *s2q, integer *lenline, ftnlen line_len,
ftnlen s2q_len)
{
/* System generated locals */
address a__1[2];
integer ret_val, i__1, i__2, i__3[2];
char ch__1[1], ch__2[2];
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer ic, len;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer ndxs2, ndxbs;
static logical intex;
extern integer lenstr_(char *, integer *, ftnlen);
/* Returns index(line,s2q) if NOT in TeX string, 0 otherwise */
ndxs2 = i_indx(line, s2q, line_len, s2q_len);
chax_(ch__1, (ftnlen)1, &c__92);
ndxbs = i_indx(line, ch__1, line_len, (ftnlen)1);
if (ndxbs == 0 || ndxs2 < ndxbs) {
ret_val = ndxs2;
} 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, lenline, line_len);
intex = TRUE_;
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;
} else {
ret_val = ndxs2;
return ret_val;
}
} else /* if(complicated condition) */ {
i__2 = ic;
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__1[0] = ch__1;
i__3[1] = 1, a__1[1] = " ";
s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)2);
if (intex && s_cmp(line + i__2, ch__2, ic + 2 - i__2, (ftnlen)
2) == 0) {
intex = FALSE_;
} else /* if(complicated condition) */ {
i__2 = ic;
/* Writing concatenation */
i__3[0] = 1, a__1[0] = " ";
chax_(ch__1, (ftnlen)1, &c__92);
i__3[1] = 1, a__1[1] = ch__1;
s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)2);
if (! intex && s_cmp(line + i__2, ch__2, ic + 2 - i__2, (
ftnlen)2) == 0) {
intex = TRUE_;
}
}
}
/* L1: */
}
}
return ret_val;
} /* ntindex_ */
/* Subroutine */ int ntrbbb_(integer *n, char *char1q, char *ulqq, integer *
iv, char *notexq, integer *lnote, ftnlen char1q_len, ftnlen ulqq_len,
ftnlen notexq_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1[3], i__2[2], i__3;
char ch__1[1];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer im, len;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern /* Subroutine */ int stop1_(void);
static char tempq[4];
extern /* Subroutine */ int printl_(char *, ftnlen), istring_(integer *,
char *, integer *, ftnlen);
/* This appends to notexq e.g. '\ibbbu1' */
if (*n >= 5) {
combbm_1.isbbm = TRUE_;
}
if (*lnote > 0) {
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__1[1] = 1, a__1[1] = ch__1;
i__1[2] = 1, a__1[2] = char1q;
s_cat(notexq, a__1, i__1, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__2[0] = ch__1;
i__2[1] = 1, a__2[1] = char1q;
s_cat(notexq, a__2, i__2, &c__2, (ftnlen)79);
}
*lnote += 2;
i__3 = *n;
for (im = 1; im <= i__3; ++im) {
/* Writing concatenation */
i__2[0] = *lnote, a__2[0] = notexq;
i__2[1] = 1, a__2[1] = "b";
s_cat(notexq, a__2, i__2, &c__2, (ftnlen)79);
++(*lnote);
/* L3: */
}
/* add the number, 0 if 12 */
/* 5/25/08 Allow >12 */
/* call istring(mod(iv,12),tempq,len) */
if (*iv < 24) {
istring_(iv, tempq, &len, (ftnlen)4);
} else if (*iv == 24) {
*(unsigned char *)tempq = '0';
len = 1;
} else {
printl_("Sorry, too man open beams", (ftnlen)25);
stop1_();
}
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = ulqq;
i__1[2] = len, a__1[2] = tempq;
s_cat(notexq, a__1, i__1, &c__3, (ftnlen)79);
*lnote = *lnote + 1 + len;
return 0;
} /* ntrbbb_ */
integer numclef_(char *clefq, ftnlen clefq_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Returns the number to be used as argument of \setclef (for MusiXTeX only) */
/* if (ichar(clefq) .lt. 55) then */
if (*(unsigned char *)clefq <= 55) {
ret_val = *(unsigned char *)clefq - 48;
if (ret_val == 7) {
ret_val = 9;
}
} else {
ret_val = i_indx("tsmanrbxxf", clefq, (ftnlen)10, (ftnlen)1) - 1;
}
return ret_val;
} /* numclef_ */
/* Subroutine */ int outbar_(integer *i__, integer *jlast)
{
/* System generated locals */
address a__1[3];
integer i__1[3], i__2;
real r__1;
char ch__1[9], ch__2[1], ch__3[11];
cilist ci__1;
/* Builtin functions */
double r_lg10(real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nfmt;
r__1 = *i__ + .5f;
nfmt = r_lg10(&r__1) + 2;
if (*jlast + 5 + nfmt < 80) {
ci__1.cierr = 0;
ci__1.ciunit = 6;
/* Writing concatenation */
i__1[0] = 5, a__1[0] = "(a5,i";
i__2 = nfmt + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__2;
i__1[2] = 3, a__1[2] = ",$)";
ci__1.cifmt = (s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)9), ch__1);
s_wsfe(&ci__1);
do_fio(&c__1, " Bar", (ftnlen)5);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 15;
/* Writing concatenation */
i__1[0] = 5, a__1[0] = "(a5,i";
i__2 = nfmt + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__2;
i__1[2] = 3, a__1[2] = ",$)";
ci__1.cifmt = (s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)9), ch__1);
s_wsfe(&ci__1);
do_fio(&c__1, " Bar", (ftnlen)5);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfe();
*jlast = *jlast + 5 + nfmt;
} else {
ci__1.cierr = 0;
ci__1.ciunit = 6;
/* Writing concatenation */
i__1[0] = 7, a__1[0] = "(/,a5,i";
i__2 = nfmt + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__2;
i__1[2] = 3, a__1[2] = ",$)";
ci__1.cifmt = (s_cat(ch__3, a__1, i__1, &c__3, (ftnlen)11), ch__3);
s_wsfe(&ci__1);
do_fio(&c__1, " Bar", (ftnlen)5);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 15;
/* Writing concatenation */
i__1[0] = 7, a__1[0] = "(/,a5,i";
i__2 = nfmt + 48;
chax_(ch__2, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__2;
i__1[2] = 3, a__1[2] = ",$)";
ci__1.cifmt = (s_cat(ch__3, a__1, i__1, &c__3, (ftnlen)11), ch__3);
s_wsfe(&ci__1);
do_fio(&c__1, " Bar", (ftnlen)5);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfe();
*jlast = nfmt + 5;
}
return 0;
} /* outbar_ */
/* Subroutine */ int pmxa_(char *basenameq, integer *lbase, logical *isfirst,
integer *nsyout, integer *nbarss, logical *optimize, ftnlen
basenameq_len)
{
/* Initialized data */
static real wtimesig = .72f;
static real wclef = .8f;
static real wkeysig = .28f;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4;
doublereal d__1, d__2;
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void), f_open(olist *), f_clos(cllist *), i_nint(real *);
double pow_dd(doublereal *, doublereal *);
integer f_rew(alist *);
/* Local variables */
extern /* Subroutine */ int g1etnote_(logical *, integer *, logical *,
logical *);
extern integer i1fnodur_(integer *, char *, ftnlen);
extern /* Subroutine */ int makeabar_(void);
static real xmtrnum0, heightil;
extern /* Subroutine */ int findeonk_(integer *, integer *, real *, real *
, real *, real *, real *);
static real elsstarg;
static logical cstuplet;
static real c__, d__;
static integer j, listcresc;
extern /* Subroutine */ int getpmxmod_(logical *, char *, ftnlen);
static integer isysendpg;
static logical fulltrans;
static integer ip, nomnsystp, kv;
static real xn;
static integer nns, isy, listdecresc, key1, key2;
static real diff;
static integer iflb, ifig, ifpb, ioff;
extern doublereal feon_(real *);
static real elsk[3999];
static integer ikey;
static real elss[125];
static logical loop;
static real wdpt;
static integer iptr;
static real diff1;
static integer ibar1;
extern doublereal f1eon_(real *);
extern /* Subroutine */ int stop1_(void);
static integer ipage, naccs;
static real celsk[4000];
static logical newmb[3999];
static integer ibars;
static real dtmin, dtmax, xelsk, wmins;
static integer ivnow, ibarb4;
static real fsyst;
static integer isyst;
static real elmin0, elmin1;
static integer isysb4;
static real omegag, facins, glueil;
extern /* Subroutine */ int outbar_(integer *, integer *);
static integer jprntb, nintpg, mtrdnp;
extern /* Subroutine */ int printl_(char *, ftnlen);
static real poenom;
static integer mtrnmp, nshort;
static real wminpt, celskb4, xiltxt;
static integer nsystp;
static real wsyspt;
extern /* Subroutine */ int g1etset_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, integer *, logical *);
static integer lenbeat, lastbar[126];
static real xilfrac;
static integer iflbnow;
static logical bottreb;
static integer mtrdenl, imovbrk, lenmult, iscount;
static real sumelsk;
static integer instnow, nsystpp;
/* Fortran I/O blocks */
static cilist io___1143 = { 0, 6, 0, 0, 0 };
static cilist io___1144 = { 0, 6, 0, 0, 0 };
static cilist io___1145 = { 0, 15, 0, "(a)", 0 };
static cilist io___1146 = { 0, 19, 0, "(i6)", 0 };
static cilist io___1158 = { 0, 6, 0, 0, 0 };
static cilist io___1162 = { 0, 6, 0, 0, 0 };
static cilist io___1168 = { 0, 15, 0, "(/,a20,i4,a1,i4)", 0 };
static cilist io___1169 = { 0, 6, 0, "(/,a20,i4,a1,i4)", 0 };
static cilist io___1174 = { 0, 6, 0, 0, 0 };
static cilist io___1176 = { 0, 6, 0, 0, 0 };
static cilist io___1177 = { 0, 6, 0, 0, 0 };
static cilist io___1178 = { 0, 6, 0, 0, 0 };
static cilist io___1179 = { 0, 15, 0, "(a,2i5)", 0 };
static cilist io___1180 = { 0, 15, 0, "(a)", 0 };
static cilist io___1182 = { 0, 12, 0, "(a)", 0 };
static cilist io___1183 = { 0, 12, 0, 0, 0 };
static cilist io___1184 = { 0, 12, 0, "(6f10.5/f10.5,3i5)", 0 };
static cilist io___1185 = { 0, 12, 0, 0, 0 };
static cilist io___1204 = { 0, 12, 0, 0, 0 };
static cilist io___1219 = { 0, 12, 0, "(i5)", 0 };
static cilist io___1237 = { 0, 12, 0, "(1pe12.5/i5,5e12.3)", 0 };
static cilist io___1238 = { 0, 13, 0, "(i5)", 0 };
static cilist io___1239 = { 0, 6, 0, "(/,a)", 0 };
static cilist io___1240 = { 0, 6, 0, 0, 0 };
static cilist io___1241 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___1242 = { 0, 15, 0, "()", 0 };
/* ccccccccccccccccccccccccccccccccccccccccccccccc */
/* c cc */
/* c Subroutine, combine with pmxb.for */
/* c */
/* ccccccccccccccccccccccccccccccccccccccccccccccc */
/* c */
/* c Need to consider X spaces in xtuplets when getting poenom, and */
/* c maybe fbar? */
/* c mx06a */
/* c ID numbers for voices when number of voices is reduced. */
/* c */
/* c mx03a */
/* c account for new fracindent for new movements. */
/* c */
/* c Known changes since pmxa. Version 1.1b (see pmxb for longer list) */
/* c */
/* c Check ID codes for slurs. */
/* c Version 1.24 still does not have details for spacing/positioning */
/* c arpeggios if there are accidentals or shifted notes or crowded scores. */
/* c Fix problem in 1.22 with arpeggios across multi-line staves */
/* c Fix problem in 1.22 with flat key signatures */
/* c Read setup data as strings */
/* c Warning for octave designation plus +/- */
/* c Don't pause for volta warning, */
/* c Macros */
/* c Correct fsyst to account for transposition and key changes. */
/* c Check for nbars > nsyst */
/* c */
/* cccccccccccccccccccccccccccccccccc */
/* Parameter adjustments */
--nbarss;
/* Function Body */
commus_1.whead20 = .3f;
if (! (*optimize)) {
s_wsle(&io___1143);
e_wsle();
s_wsle(&io___1144);
do_lio(&c__9, &c__1, "Starting first PMX pass", (ftnlen)23);
e_wsle();
s_wsfe(&io___1145);
do_fio(&c__1, " Starting first PMX pass", (ftnlen)24);
e_wsfe();
}
if (*isfirst) {
o__1.oerr = 0;
o__1.ounit = 19;
o__1.ofnmlen = 11;
o__1.ofnm = "pmxaerr.dat";
o__1.orl = 0;
o__1.osta = 0;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
s_wsfe(&io___1146);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
cl__1.cerr = 0;
cl__1.cunit = 19;
cl__1.csta = 0;
f_clos(&cl__1);
}
if (! (*optimize)) {
jprntb = 81;
}
commac_1.macuse = 0;
comkeys_1.ornrpt = FALSE_;
comkeys_1.stickys = FALSE_;
commac_1.mrecord = FALSE_;
commac_1.mplay = FALSE_;
c1omget_1.lastchar = FALSE_;
comnvst_2.novshrinktop = FALSE_;
cstuplet = FALSE_;
comslur_1.fontslur = TRUE_;
comligfont_1.isligfont = FALSE_;
fulltrans = FALSE_;
for (c1omnotes_1.ibarcnt = 1; c1omnotes_1.ibarcnt <= 3999;
++c1omnotes_1.ibarcnt) {
c1omnotes_1.udsp[c1omnotes_1.ibarcnt - 1] = 0.f;
c1omnotes_1.wminnh[c1omnotes_1.ibarcnt - 1] = -1.f;
/* L42: */
}
/* Initialize input buffer */
c1omget_1.lenbuf0 = inbuff_1.ipbuf;
inbuff_1.ipbuf = 0;
inbuff_1.ilbuf = 1;
g1etset_(&a1ll_2.nv, &comkeys_1.noinst, &a1ll_2.mtrnuml, &mtrdenl, &
mtrnmp, &mtrdnp, &xmtrnum0, comkeys_1.newkey, &compage_1.npages, &
compage_1.nsyst, &commus_1.musize, &bottreb);
/* Set up list of instrument numbers (iv) */
ivnow = 0;
i__1 = comkeys_1.noinst;
for (instnow = 1; instnow <= i__1; ++instnow) {
i__2 = c1omget_1.nsperi[instnow - 1];
for (iscount = 1; iscount <= i__2; ++iscount) {
++ivnow;
cominsttrans_1.instno[ivnow - 1] = instnow;
/* L14: */
}
/* L13: */
}
/* Save initial meter for midi */
if (! (*isfirst) && compage_1.npages == 0) {
s_wsle(&io___1158);
do_lio(&c__9, &c__1, "Sorry, must have npages>0 for optimization.", (
ftnlen)43);
e_wsle();
stop1_();
}
*nsyout = compage_1.nsyst;
/* isig1 will be changed in getnote if there is a transposition */
comkeys_1.isig1 = comkeys_1.newkey[0];
if (compage_1.npages > compage_1.nsyst) {
printl_("npages > nsyst in input. Please fix the input.", (ftnlen)47)
;
stop1_();
}
/* fbar = afterruleskip/elemskip */
/* apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt */
c1ommvl_1.fbar = 1.f;
c1omnotes_1.wheadpt = commus_1.whead20 * commus_1.musize;
ifig = 0;
compage_1.usefig = TRUE_;
lenbeat = i1fnodur_(&mtrdenl, "x", (ftnlen)1);
lenmult = 1;
if (mtrdenl == 2) {
lenbeat = 16;
lenmult = 2;
}
a1ll_2.lenbr1 = lenmult * a1ll_2.mtrnuml * lenbeat;
r__1 = lenmult * xmtrnum0 * lenbeat;
a1ll_2.lenbr0 = i_nint(&r__1);
a1ll_2.mtrnuml = 0;
if (a1ll_2.lenbr0 != 0) {
c1omnotes_1.ibaroff = 1;
a1ll_2.lenbar = a1ll_2.lenbr0;
} else {
c1omnotes_1.ibaroff = 0;
a1ll_2.lenbar = a1ll_2.lenbr1;
}
c1omnotes_1.ibarcnt = 0;
c1omnotes_1.nptr[0] = 1;
a1ll_2.iccount = 128;
compage_1.nmovbrk = 0;
compage_1.nflb = 0;
compage_1.nfpb = 0;
compage_1.ipagfpb[0] = 1;
compage_1.isysfpb[0] = 1;
compage_1.ibarflb[0] = 1;
compage_1.isysflb[0] = 1;
compage_1.nistaff[0] = a1ll_2.nv - 1;
/* Check for pmx.mod */
c1omget_1.linesinpmxmod = 0;
/* line1pmxmod = ilbuf */
getpmxmod_(&c_true, " ", (ftnlen)1);
if (! (*isfirst) && c1omget_1.linesinpmxmod > 0) {
s_wsle(&io___1162);
do_lio(&c__9, &c__1, "Sorry, cannot optimize if there is a pmx.mod f"
"ile", (ftnlen)49);
e_wsle();
stop1_();
}
/* Initialize for loop over lines */
comkeys_1.nkeys = 1;
comkeys_1.ibrkch[0] = 1;
comkeys_1.mbrestsav = 0;
comkeys_1.shifton = FALSE_;
a1ll_2.firstline = TRUE_;
a1ll_2.newmeter = FALSE_;
c1omget_1.ihead = 0;
c1omget_1.isheadr = FALSE_;
c1omnotes_1.gotclef = FALSE_;
comkeys_1.idsig = 0;
c1omnotes_1.iddot = 0;
compage_1.fintstf = -1.f;
compage_1.gintstf = 1.f;
listcresc = 0;
listdecresc = 0;
L30:
loop = TRUE_;
comkeys_1.iskchb = FALSE_;
c1omget_1.issegno = FALSE_;
a1ll_2.nbars = 0;
c1omnotes_1.ibarmbr = 0;
/* L3: */
i__1 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__1; ++a1ll_2.iv) {
c1ommvl_1.nvmx[a1ll_2.iv - 1] = 1;
c1ommvl_1.ivmx[a1ll_2.iv - 1] = a1ll_2.iv;
a1ll_2.itsofar[a1ll_2.iv - 1] = 0;
a1ll_2.nnl[a1ll_2.iv - 1] = 0;
for (j = 1; j <= 200; ++j) {
a1ll_2.rest[a1ll_2.iv + j * 24 - 25] = FALSE_;
c1ommvl_1.nacc[a1ll_2.iv + j * 24 - 25] = 0.f;
/* L5: */
}
/* L4: */
}
a1ll_2.iv = 1;
c1ommvl_1.ivx = 1;
c1omget_1.fbon = FALSE_;
comkeys_1.barend = FALSE_;
c1omget_1.isvolt = FALSE_;
L2:
if (loop) {
/* Within this short loop, nv voices are filled up for the duration of a block. */
/* On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) */
/* nodur(..),rest(..). nnl will later be */
/* increased and things slid around as accidental skips are added. */
g1etnote_(&loop, &ifig, optimize, &fulltrans);
if (c1omget_1.lastchar) {
goto L20;
}
goto L2;
}
if (comkeys_1.mbrestsav > 0) {
printl_(" ", (ftnlen)1);
printl_("You must enter the same multibar rest in ALL parts", (ftnlen)
50);
stop1_();
}
i__1 = a1ll_2.nbars;
for (a1ll_2.ibar = 1; a1ll_2.ibar <= i__1; ++a1ll_2.ibar) {
++c1omnotes_1.ibarcnt;
/* The following is just a signal to start a new bar when cataloging spaces */
/* for catspace(...) */
c1omnotes_1.nptr[c1omnotes_1.ibarcnt] = c1omnotes_1.nptr[
c1omnotes_1.ibarcnt - 1];
newmb[c1omnotes_1.ibarcnt - 1] = FALSE_;
if (a1ll_2.newmeter && a1ll_2.ibar == 1) {
newmb[c1omnotes_1.ibarcnt - 1] = TRUE_;
}
/* Above is only for spacing calcs later on. Remember new meter can only occur */
/* at START of a new input line (ibar = 1) */
if (a1ll_2.ibar != c1omnotes_1.ibarmbr) {
if (! (*optimize)) {
i__2 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff;
outbar_(&i__2, &jprntb);
}
} else {
if (! (*optimize)) {
s_wsfe(&io___1168);
do_fio(&c__1, " Multibar rest, bars", (ftnlen)20);
i__2 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "-", (ftnlen)1);
i__3 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
c1omnotes_1.mbrest - 1;
do_fio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___1169);
do_fio(&c__1, " Multibar rest, bars", (ftnlen)20);
i__2 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "-", (ftnlen)1);
i__3 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff +
c1omnotes_1.mbrest - 1;
do_fio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
e_wsfe();
jprntb = 0;
}
c1omnotes_1.ibaroff = c1omnotes_1.ibaroff - c1omnotes_1.mbrest +
1;
}
if (a1ll_2.firstline && a1ll_2.lenbr0 != 0) {
if (a1ll_2.ibar == 1) {
a1ll_2.lenbar = a1ll_2.lenbr0;
} else {
a1ll_2.lenbar = a1ll_2.lenbr1;
}
}
if (a1ll_2.ibar > 1) {
/* For bars after first, slide all stuff down to beginning of arrays */
i__2 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__2; ++a1ll_2.iv) {
i__3 = c1ommvl_1.nvmx[a1ll_2.iv - 1];
for (kv = 1; kv <= i__3; ++kv) {
c1ommvl_1.ivx = c1ommvl_1.ivmx[a1ll_2.iv + kv * 24 - 25];
ioff = a1ll_2.nib[c1ommvl_1.ivx + (a1ll_2.ibar - 1) * 24
- 25];
i__4 = a1ll_2.nib[c1ommvl_1.ivx + a1ll_2.ibar * 24 - 25]
- ioff;
for (ip = 1; ip <= i__4; ++ip) {
a1ll_2.nodur[c1ommvl_1.ivx + ip * 24 - 25] =
a1ll_2.nodur[c1ommvl_1.ivx + (ip + ioff) * 24
- 25];
a1ll_2.rest[c1ommvl_1.ivx + ip * 24 - 25] =
a1ll_2.rest[c1ommvl_1.ivx + (ip + ioff) * 24
- 25];
c1ommvl_1.nacc[c1ommvl_1.ivx + ip * 24 - 25] =
c1ommvl_1.nacc[c1ommvl_1.ivx + (ip + ioff) *
24 - 25];
/* L12: */
}
/* L11: */
}
}
}
i__3 = a1ll_2.nv;
for (a1ll_2.iv = 1; a1ll_2.iv <= i__3; ++a1ll_2.iv) {
i__2 = c1ommvl_1.nvmx[a1ll_2.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
ioff = 0;
if (a1ll_2.ibar > 1) {
ioff = a1ll_2.nib[c1ommvl_1.ivmx[a1ll_2.iv + kv * 24 - 25]
+ (a1ll_2.ibar - 1) * 24 - 25];
}
/* L67: */
}
}
makeabar_();
elsk[c1omnotes_1.ibarcnt - 1] = linecom_1.elskb + c1ommvl_1.fbar;
/* L10: */
}
a1ll_2.newmeter = FALSE_;
a1ll_2.firstline = FALSE_;
goto L30;
L20:
/* Vertical analysis. */
if (compage_1.npages == 0) {
if (compage_1.nsyst == 0) {
s_wsle(&io___1174);
do_lio(&c__9, &c__1, "When npages=0, must set nsyst=bars/syst, n"
"ot 0", (ftnlen)46);
e_wsle();
stop1_();
}
compage_1.nsyst = (c1omnotes_1.ibarcnt - 1) / compage_1.nsyst + 1;
if (a1ll_2.nv == 1) {
nsystpp = 12;
} else if (a1ll_2.nv == 2) {
nsystpp = 7;
} else if (a1ll_2.nv == 3) {
nsystpp = 5;
} else if (a1ll_2.nv == 4) {
nsystpp = 3;
} else if (a1ll_2.nv <= 7) {
nsystpp = 2;
} else {
nsystpp = 1;
}
compage_1.npages = (compage_1.nsyst - 1) / nsystpp + 1;
}
/* Check nsyst vs ibarcnt */
if (compage_1.nsyst > c1omnotes_1.ibarcnt) {
s_wsle(&io___1176);
e_wsle();
s_wsle(&io___1177);
do_lio(&c__9, &c__1, "nsyst,ibarcnt:", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&compage_1.nsyst, (ftnlen)sizeof(integer)
);
do_lio(&c__3, &c__1, (char *)&c1omnotes_1.ibarcnt, (ftnlen)sizeof(
integer));
e_wsle();
s_wsle(&io___1178);
do_lio(&c__9, &c__1, "There are more systems than bars.", (ftnlen)33);
e_wsle();
s_wsfe(&io___1179);
do_fio(&c__1, " nsyst,ibarcnt:", (ftnlen)15);
do_fio(&c__1, (char *)&compage_1.nsyst, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c1omnotes_1.ibarcnt, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___1180);
do_fio(&c__1, " There are more systems than bars.", (ftnlen)34);
e_wsfe();
stop1_();
}
/* Set up dummy forced line & page breaks after last real one */
++compage_1.nflb;
compage_1.ibarflb[compage_1.nflb] = c1omnotes_1.ibarcnt + 1;
compage_1.isysflb[compage_1.nflb] = compage_1.nsyst + 1;
++compage_1.nfpb;
compage_1.ipagfpb[compage_1.nfpb] = compage_1.npages + 1;
compage_1.isysfpb[compage_1.nfpb] = compage_1.nsyst + 1;
heightil = compage_1.ptheight * 4.f / commus_1.musize;
o__1.oerr = 0;
o__1.ounit = 12;
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);
s_wsfe(&io___1182);
do_fio(&c__1, basenameq, (*lbase));
e_wsfe();
s_wsle(&io___1183);
do_lio(&c__3, &c__1, (char *)&(*lbase), (ftnlen)sizeof(integer));
e_wsle();
/* Pass to pmxb the initial signature, including effect of transposition. */
s_wsfe(&io___1184);
do_fio(&c__1, (char *)&c1ommvl_1.fbar, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&c1omnotes_1.wheadpt, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cblock_1.etait, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cblock_1.etatc, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cblock_1.etacs1, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cblock_1.etatop, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cblock_1.etabot, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&cominbot_1.inbothd, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&cblock_1.inhnoh, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&comkeys_1.isig1, (ftnlen)sizeof(integer));
e_wsfe();
s_wsle(&io___1185);
do_lio(&c__3, &c__1, (char *)&compage_1.npages, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&compage_1.widthpt, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&compage_1.ptheight, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&compage_1.hoffpt, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&compage_1.voffpt, (ftnlen)sizeof(real));
do_lio(&c__3, &c__1, (char *)&compage_1.nsyst, (ftnlen)sizeof(integer));
e_wsle();
iflbnow = -1;
isysb4 = 0;
i__1 = compage_1.nfpb;
for (ifpb = 1; ifpb <= i__1; ++ifpb) {
/* Each time thru this loop is like a single score with several pages */
compage_1.npages = compage_1.ipagfpb[ifpb] - compage_1.ipagfpb[ifpb -
1];
compage_1.nsyst = compage_1.isysfpb[ifpb] - compage_1.isysfpb[ifpb -
1];
nomnsystp = (compage_1.nsyst - 1) / compage_1.npages + 1;
nshort = nomnsystp * compage_1.npages - compage_1.nsyst;
i__2 = compage_1.npages;
for (ipage = 1; ipage <= i__2; ++ipage) {
nsystp = nomnsystp;
if (ipage <= nshort) {
--nsystp;
}
/* Last system number on this page: */
isysendpg = isysb4 + nsystp;
nintpg = 0;
i__3 = isysendpg;
for (isy = isysb4 + 1; isy <= i__3; ++isy) {
if (compage_1.isysflb[iflbnow + 1] == isy) {
++iflbnow;
}
nintpg += compage_1.nistaff[iflbnow];
/* L15: */
}
xilfrac = 0.f;
xiltxt = 0.f;
if (ipage == 1 && c1omget_1.ihead > 0) {
/* Needn't zero out ihead after printing titles if we only allow titles at top? */
if ((c1omget_1.ihead & 1) == 1) {
xiltxt += cblock_1.hgtin * 4 / commus_1.musize;
xilfrac += cblock_1.etait;
}
if ((c1omget_1.ihead & 2) == 2) {
xiltxt += cblock_1.hgtti * 4 / commus_1.musize;
xilfrac += cblock_1.etatc;
}
if ((c1omget_1.ihead & 4) == 4) {
xiltxt += cblock_1.hgtco * 4 / commus_1.musize;
xilfrac += cblock_1.etacs1;
} else {
/* Use double the title-composer space if there is no composer */
xilfrac += cblock_1.etatc;
}
}
d__ = xilfrac + nsystp - 1 + cblock_1.etatop + cblock_1.etabot;
/* C = nsystp*(nv-1) */
c__ = (real) nintpg;
/* xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn */
xn = heightil - xiltxt - (nintpg + nsystp << 2) - (nsystp - 1) *
cblock_1.xilbn;
if (bottreb) {
xn -= (nsystp - 1) * cblock_1.xilbtc;
}
if (c1omget_1.ihead == 0 && c1omget_1.isheadr) {
xn -= cblock_1.xilhdr;
}
if (ifig == 1) {
xn -= nsystp * cblock_1.xilfig;
}
glueil = (xn - cblock_1.b * c__) / (d__ + cblock_1.a * c__);
omegag = (cblock_1.b * d__ + cblock_1.a * xn) / (d__ + cblock_1.a
* c__);
/* G = \interlines between systems */
/* omega*G = \interlines between staves of the same system */
/* \interstaff = 4+omega*G */
/* C = total number of interstaff spaces in the page */
/* D = omega-indep factors for scalable height = nsy-1 (intersystem glue) */
/* + etatop + etabot + etatxt + */
/* N = scaleable height (\interlignes) = height - htext - staff heights - xil */
/* xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles */
/* + (nsy-1)*xiltcb for treble clef bottoms */
/* + nsy*xilfig for figures */
/* G = N/(D + omega * C) = glueil, (1) */
/* But (empirically) omega*G = a*G + b (2) */
/* with a=1.071 and b=2.714 */
/* Solving (1) and (2) gives */
/* G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) */
/* Pass to pmxb omega*G (=\interstaff-4) */
/* (etatop,bot,it,tc,cx)*G as inputs to \titles */
/* glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) */
/* * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) */
/* xnsttop = glueil*etatop */
/* xintstaff = 4+gfact*glueil */
/* Only the first page will get local adjustment now if needed, others in pmxb */
if (ifpb == 1 && ipage == 1 && compage_1.fintstf > 0.f) {
facins = compage_1.fintstf;
compage_1.fintstf = -1.f;
} else {
/* gintstf = 1.0 by default, but may be changed with AI */
facins = compage_1.gintstf;
}
s_wsle(&io___1204);
do_lio(&c__3, &c__1, (char *)&nsystp, (ftnlen)sizeof(integer));
/* Computing MAX */
r__2 = 0.f, r__3 = cblock_1.etatop * glueil;
r__1 = dmax(r__2,r__3);
do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real));
r__4 = facins * (omegag + 4);
do_lio(&c__4, &c__1, (char *)&r__4, (ftnlen)sizeof(real));
e_wsle();
c1omget_1.ihead = 0;
c1omget_1.isheadr = FALSE_;
isysb4 = isysendpg;
/* L7: */
}
/* L8: */
}
/* Done with vertical, now do horizontals */
celsk[1] = elsk[0];
i__1 = c1omnotes_1.ibarcnt;
for (a1ll_2.ibar = 2; a1ll_2.ibar <= i__1; ++a1ll_2.ibar) {
celsk[a1ll_2.ibar] = celsk[a1ll_2.ibar - 1] + elsk[a1ll_2.ibar - 1];
/* L21: */
}
lastbar[0] = 0;
ibar1 = 1;
wmins = -1.f;
iflb = 1;
imovbrk = 0;
ikey = 1;
/* Return nsyst to its *total* value */
compage_1.nsyst = compage_1.isysfpb[compage_1.nfpb] - 1;
i__1 = compage_1.nsyst;
for (isyst = 1; isyst <= i__1; ++isyst) {
if (isyst == compage_1.isysflb[iflb]) {
++iflb;
}
if (compage_1.nmovbrk > 0 && imovbrk < compage_1.nmovbrk) {
if (isyst == compage_1.isysmb[imovbrk + 1]) {
++imovbrk;
}
}
ibarb4 = lastbar[isyst - 1];
if (isyst == 1) {
if (*isfirst) {
elsstarg = celsk[compage_1.ibarflb[1] - 1] / (
compage_1.isysflb[1] - 1 - c1omget_1.fracindent) * (1
- c1omget_1.fracindent);
}
celskb4 = 0.f;
} else {
celskb4 = celsk[ibarb4];
/* Must dimension isysmb(0:*) just so I can execute this test! */
if (*isfirst) {
if (compage_1.nmovbrk > 0 && isyst == compage_1.isysmb[
imovbrk]) {
/* First syst after forced line break. There may be indentation. */
elsstarg = (celsk[compage_1.ibarflb[iflb] - 1] - celskb4)
/ (compage_1.isysflb[iflb] - isyst -
compage_1.fracsys[imovbrk - 1]) * (1 -
compage_1.fracsys[imovbrk - 1]);
} else {
/* There is no indentation to deal with */
elsstarg = (celsk[compage_1.ibarflb[iflb] - 1] - celskb4)
/ (compage_1.isysflb[iflb] - isyst);
}
}
}
if (*isfirst) {
diff1 = (r__1 = elsstarg - elsk[ibarb4], dabs(r__1));
i__2 = c1omnotes_1.ibarcnt;
for (a1ll_2.ibar = ibarb4 + 2; a1ll_2.ibar <= i__2; ++a1ll_2.ibar)
{
diff = elsstarg - (celsk[a1ll_2.ibar] - celskb4);
if (dabs(diff) >= diff1) {
goto L24;
}
diff1 = dabs(diff);
/* L23: */
}
L24:
--a1ll_2.ibar;
lastbar[isyst] = a1ll_2.ibar;
nbarss[isyst] = a1ll_2.ibar - ibarb4;
} else {
/* nbarss is given as an input, must compute lastbar and ibar */
lastbar[isyst] = nbarss[isyst] + ibarb4;
a1ll_2.ibar = lastbar[isyst];
}
/* elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. */
elss[isyst - 1] = celsk[a1ll_2.ibar] - celskb4;
s_wsfe(&io___1219);
i__2 = lastbar[isyst - 1] + 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
e_wsfe();
/* Transposed sigs are isig1, newkey(2,3,...). */
if (ikey == 1) {
key1 = comkeys_1.isig1;
} else {
key1 = comkeys_1.newkey[ikey - 1];
}
fsyst = wclef + abs(key1) * wkeysig + 2.f / commus_1.musize;
xelsk = 0.f;
L1:
if (ikey < comkeys_1.nkeys) {
if (comkeys_1.ibrkch[ikey] <= lastbar[isyst]) {
/* Add space for all key changes */
++ikey;
key2 = comkeys_1.newkey[ikey - 1];
/* Computing MAX */
/* Computing MAX */
i__5 = abs(key1), i__6 = abs(key2);
i__3 = (i__2 = key2 - key1, abs(i__2)), i__4 = max(i__5,i__6);
naccs = max(i__3,i__4);
fsyst += naccs * wkeysig;
/* Account for afterruleskips (fbar) */
xelsk += c1ommvl_1.fbar / 2;
if (comkeys_1.ibrkch[ikey - 1] < lastbar[isyst] && !
comkeys_1.kchmid[ikey - 1]) {
xelsk += -1.f;
}
key1 = key2;
goto L1;
}
}
/* Add extra fixed space for double bar */
if (isyst == compage_1.nsyst) {
fsyst += 4.5f / commus_1.musize;
}
/* Add extra fixed space for initial time signature */
if (isyst == 1) {
fsyst += wtimesig;
}
/* Add extra fixed space for time signature changes & user-defined spaces */
i__2 = lastbar[isyst];
for (ibars = ibarb4 + 1; ibars <= i__2; ++ibars) {
if (newmb[ibars - 1]) {
fsyst += wtimesig;
}
fsyst += c1omnotes_1.udsp[ibars - 1] / commus_1.musize;
/* L26: */
}
if (isyst == 1) {
wdpt = compage_1.widthpt * (1 - c1omget_1.fracindent);
} else {
if (compage_1.nmovbrk > 0 && imovbrk > 0 && isyst ==
compage_1.isysmb[imovbrk]) {
wdpt = compage_1.widthpt * (1 - compage_1.fracsys[imovbrk - 1]
);
} else {
wdpt = compage_1.widthpt;
}
}
wsyspt = wdpt - fsyst * commus_1.musize - nbarss[isyst] * .4f;
/* Checks for min spacing */
/* Get min allowable space */
dtmin = 1e3f;
i__2 = ibar1 + nbarss[isyst] - 1;
for (a1ll_2.ibar = ibar1; a1ll_2.ibar <= i__2; ++a1ll_2.ibar) {
/* Computing MIN */
r__1 = dtmin, r__2 = linecom_1.tnminb[a1ll_2.ibar - 1];
dtmin = dmin(r__1,r__2);
if (c1omnotes_1.wminnh[a1ll_2.ibar - 1] >= 0.f) {
wmins = c1omnotes_1.wminnh[a1ll_2.ibar - 1];
}
/* L45: */
}
if (wmins < 0.f) {
wmins = .3f;
}
wminpt = (wmins + 1) * .3f * commus_1.musize;
/* Find max duration & # of notes for this system */
dtmax = 0.f;
nns = 0;
i__2 = c1omnotes_1.nptr[ibar1 + nbarss[isyst] - 1] - 1;
for (iptr = c1omnotes_1.nptr[ibar1 - 1]; iptr <= i__2; ++iptr) {
/* Computing MAX */
r__1 = dtmax, r__2 = c1omnotes_1.durb[iptr - 1];
dtmax = dmax(r__1,r__2);
nns += c1omnotes_1.nnpd[iptr - 1];
/* L43: */
}
elmin0 = wsyspt * f1eon_(&dtmin) / (elss[isyst - 1] + xelsk);
if (elmin0 >= wminpt) {
/* Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; */
/* there is no need to "flatten" */
sumelsk = elss[isyst - 1] - c1ommvl_1.fbar * nbarss[isyst];
comeon_1.eonk = 0.f;
comeon_1.ewmxk = 1.f;
} else {
elmin1 = wsyspt / ((c1ommvl_1.fbar * nbarss[isyst] + xelsk) /
f1eon_(&dtmax) + nns);
if (elmin1 <= wminpt) {
/* print* */
/* print*,'In system #',isyst,' cannot meet min. space rqmt' */
/* write(15,'(/a,i5,a)') */
/* * 'In system #',isyst,' cannot meet min. space rqmt' */
comeon_1.eonk = .9f;
} else {
/* Find eonk by Newton method */
/* eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) */
i__2 = c1omnotes_1.nptr[ibar1 + nbarss[isyst] - 1] - 1;
r__1 = wsyspt / wminpt;
r__2 = c1ommvl_1.fbar * nbarss[isyst] + xelsk;
r__3 = (wminpt - elmin0) / (elmin1 - elmin0);
findeonk_(&c1omnotes_1.nptr[ibar1 - 1], &i__2, &r__1, &r__2, &
dtmin, &dtmax, &r__3);
comeon_1.eonk = dmin(.9f,comeon_1.eonk);
}
d__1 = (doublereal) f1eon_(&dtmax);
d__2 = (doublereal) comeon_1.eonk;
comeon_1.ewmxk = pow_dd(&d__1, &d__2);
/* Recompute poenom! */
sumelsk = 0.f;
i__2 = c1omnotes_1.nptr[ibar1 + nbarss[isyst] - 1] - 1;
for (iptr = c1omnotes_1.nptr[ibar1 - 1]; iptr <= i__2; ++iptr) {
r__1 = c1omnotes_1.durb[iptr - 1] / c1omnotes_1.sqzb[iptr - 1]
;
sumelsk += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr
- 1] * feon_(&r__1);
/* L44: */
}
}
poenom = wsyspt / (sumelsk + c1ommvl_1.fbar * nbarss[isyst] + xelsk);
/* Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 */
if (isyst > 0) {
if (compage_1.nmovbrk > 0 && imovbrk > 0 && isyst ==
compage_1.isysmb[imovbrk]) {
c1omget_1.fracindent = compage_1.fracsys[imovbrk - 1];
} else {
c1omget_1.fracindent = 0.f;
}
}
s_wsfe(&io___1237);
do_fio(&c__1, (char *)&poenom, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&nbarss[isyst], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&sumelsk, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&fsyst, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&c1omget_1.fracindent, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&comeon_1.eonk, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&comeon_1.ewmxk, (ftnlen)sizeof(real));
e_wsfe();
ibar1 += nbarss[isyst];
/* L22: */
}
al__1.aerr = 0;
al__1.aunit = 12;
f_rew(&al__1);
o__1.oerr = 0;
o__1.ounit = 13;
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);
s_wsfe(&io___1238);
do_fio(&c__1, (char *)&ifig, (ftnlen)sizeof(integer));
e_wsfe();
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
inbuff_1.ilbuf = 1;
inbuff_1.ipbuf = 0;
if (! (*optimize)) {
s_wsfe(&io___1239);
do_fio(&c__1, " Done with first pass", (ftnlen)21);
e_wsfe();
s_wsle(&io___1240);
e_wsle();
s_wsfe(&io___1241);
do_fio(&c__1, " Done with first pass", (ftnlen)21);
e_wsfe();
s_wsfe(&io___1242);
e_wsfe();
}
/* Following syntax is needed since pmxa is called with literal argument .false. */
if (*isfirst) {
*isfirst = FALSE_;
}
return 0;
} /* pmxa_ */
/* Subroutine */ int pmxb_(logical *inlast, real *poevec, integer *ncalls,
logical *optimize)
{
/* System generated locals */
address a__1[12], a__2[6], a__3[4], a__4[2], a__5[3], a__6[10], a__7[9],
a__8[5], a__9[2], a__10[8], a__11[14];
integer i__1, i__2, i__3[12], i__4[6], i__5[4], i__6[2], i__7, i__8[3],
i__9[10], i__10[9], i__11[5], i__12[2], i__13, i__14[8], i__15[14]
;
real r__1, r__2;
char ch__1[1], ch__2[46], ch__3[23], ch__4[26], ch__5[27], ch__6[20],
ch__7[29], ch__8[8], ch__9[35], ch__10[14], ch__11[19], ch__12[
107], ch__13[12], ch__14[15], ch__15[13], ch__16[9], ch__17[11],
ch__18[32], ch__19[10], ch__20[4], ch__21[16], ch__22[33], ch__23[
18], ch__24[82], ch__25[66], ch__26[60], ch__27[45], ch__28[6],
ch__29[17], ch__30[76], ch__31[40], ch__32[69], ch__33[41],
ch__34[44], ch__35[5], ch__36[7], ch__37[24], ch__38[22], ch__39[
96];
cilist ci__1;
icilist ici__1;
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void), s_rsfe(cilist *), e_rsfe(void), s_rsle(cilist *),
e_rsle(void);
double r_mod(real *, real *);
integer i_nint(real *), pow_ii(integer *, integer *), f_open(olist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
double r_lg10(real *);
integer i_indx(char *, char *, ftnlen, ftnlen);
double r_dim(real *, real *);
integer i_dim(integer *, integer *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), e_wsfi(void), lbit_shift(integer, integer),
f_clos(cllist *), f_rew(alist *);
/* Local variables */
static integer nbarss;
static real elsktot;
static integer ndigbn, indsym;
extern /* Subroutine */ int wgmeter_(integer *, integer *);
static integer mtrnms;
static real xnstbot;
static integer iptemp, islide, ipnew, iudorn, idynd;
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
static integer itxtdyn, isdata, iarps;
extern /* Subroutine */ int make1bar_(integer *, real *, real *, logical *
, real *, integer *, integer *, integer *), make2bar_(integer *,
real *, real *, logical *, real *, integer *, integer *, integer *
, char *, ftnlen);
static real hardb4;
extern /* Subroutine */ int askfig_(char *, integer *, char *, integer *,
logical *, logical *, ftnlen, ftnlen);
static real xmtrnum0;
extern integer igetbits_(integer *, integer *, integer *);
extern /* Subroutine */ int newvoice_(integer *, char *, logical *,
ftnlen);
static logical lrptpend;
extern /* Subroutine */ int setmeter_(integer *, integer *, integer *,
integer *), puttitle_(integer *, real *, real *, char *, real *,
real *, real *, integer *, logical *, char *, ftnlen, ftnlen);
static integer iornqnow, i__;
static char basenameq[44], pathnameq[40];
extern /* Subroutine */ int midievent_(char *, integer *, integer *,
ftnlen);
static real xintstaff[40];
static integer ia, ig, il, ip, it, kv, ip2, ibc, icc, ipa, ipi;
static real esk;
static char nmq[40];
static integer iiv;
static real poe, frac;
static integer ifig, jfig, ndig;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static real hesk[23];
static integer ioff;
extern doublereal feon_(real *);
static char fmtq[24];
static logical loop;
static real hpts[23], wdpt;
static logical lrpt, rrpt;
static integer lnmq, icrd, idyn;
static real tglp1;
extern /* Subroutine */ int stop1_(void);
static logical clchb;
static integer lbase, lclef;
static char charq[1];
static logical clchv[24], slint;
static integer istop[80];
static real squez[80];
static logical ismbr;
static real etait, etatc, etacs1;
static integer nsyst, lpath, iauto;
static real slfac1;
static integer lnote, nclef, ipnow;
extern /* Subroutine */ int linebreakties_(integer *, integer *, integer *
, integer *, integer *, logical *, char *, ftnlen);
static real fsyst;
static integer isdat;
extern integer ncmid_(integer *, integer *);
extern /* Subroutine */ int writesetsign_(integer *, integer *, integer *,
logical *);
static integer naccs;
static logical evolta;
static integer numbms[24], istart[80];
static logical cwrest[24], svolta;
static char notexq[79];
static logical onvolt;
static real tstart[80];
static logical putmbr;
static real etatop, etabot;
static integer inhnoh;
extern /* Subroutine */ int getset_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, real *, logical *, char *, char *, char *, char *,
integer *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
static integer noinst;
static logical istype0;
static integer npages, ibcoff, ibmrep, nhstot, jprntb, nhssys;
extern /* Subroutine */ int addmidi_(integer *, integer *, integer *,
integer *, real *, logical *, logical *);
static integer lenbeat;
extern /* Subroutine */ int outbar_(integer *, integer *);
static real ptsndb, ptsndv;
extern /* Subroutine */ int wsclef_(integer *, integer *, char *, integer
*, ftnlen), topfile_(char *, integer *, integer *, char *,
integer *, integer *, real *, integer *, integer *, logical *,
real *, logical *, ftnlen, ftnlen);
static logical ispstie, vshrink;
static integer isyscnt;
static real xntrial;
extern integer ifnodur_(integer *, char *, ftnlen);
static integer isystpg;
extern /* Subroutine */ int getnote_(logical *);
static real ptsdflt;
extern /* Subroutine */ int clefsym_(integer *, char *, integer *,
integer *, ftnlen);
static integer islnow, lvoltxt;
static real xnsttop[40];
static integer iplnow;
/* Fortran I/O blocks */
static cilist io___1243 = { 0, 6, 0, 0, 0 };
static cilist io___1244 = { 0, 6, 0, 0, 0 };
static cilist io___1245 = { 0, 6, 0, 0, 0 };
static cilist io___1246 = { 0, 15, 0, "(a)", 0 };
static cilist io___1249 = { 0, 12, 0, "(a)", 0 };
static cilist io___1251 = { 0, 12, 0, 0, 0 };
static cilist io___1253 = { 0, 12, 0, 0, 0 };
static cilist io___1269 = { 0, 6, 0, 0, 0 };
static cilist io___1270 = { 0, 12, 0, 0, 0 };
static cilist io___1276 = { 0, 13, 0, 0, 0 };
static cilist io___1278 = { 0, 14, 0, "(a)", 0 };
static cilist io___1281 = { 0, 11, 0, "(a)", 0 };
static cilist io___1282 = { 0, 11, 0, "(a)", 0 };
static cilist io___1283 = { 0, 11, 0, "(a)", 0 };
static cilist io___1286 = { 0, 11, 0, "(a)", 0 };
static cilist io___1296 = { 0, 11, 0, "(a)", 0 };
static cilist io___1298 = { 0, 6, 0, "(/,a20,i4,a1,i4)", 0 };
static cilist io___1299 = { 0, 15, 0, "(/,a20,i4,a1,i4)", 0 };
static cilist io___1303 = { 0, 11, 0, "(a)", 0 };
static cilist io___1304 = { 0, 11, 0, "(a14,f4.1,a)", 0 };
static cilist io___1313 = { 0, 11, 0, "(a)", 0 };
static cilist io___1322 = { 0, 11, 0, "(a)", 0 };
static cilist io___1323 = { 0, 11, 0, "(a)", 0 };
static cilist io___1324 = { 0, 12, 0, 0, 0 };
static cilist io___1327 = { 0, 6, 0, 0, 0 };
static cilist io___1328 = { 0, 6, 0, 0, 0 };
static cilist io___1331 = { 0, 11, 0, "(a)", 0 };
static cilist io___1332 = { 0, 11, 0, "(a)", 0 };
static cilist io___1333 = { 0, 11, 0, "(a)", 0 };
static cilist io___1334 = { 0, 11, 0, "(a)", 0 };
static cilist io___1335 = { 0, 11, 0, "(a)", 0 };
static cilist io___1336 = { 0, 11, 0, "(a)", 0 };
static cilist io___1339 = { 0, 11, 0, "(a)", 0 };
static cilist io___1340 = { 0, 11, 0, "(a)", 0 };
static cilist io___1342 = { 0, 11, 0, "(a)", 0 };
static cilist io___1343 = { 0, 11, 0, "(a)", 0 };
static cilist io___1353 = { 0, 11, 0, "(a)", 0 };
static cilist io___1354 = { 0, 12, 0, 0, 0 };
static cilist io___1356 = { 0, 14, 0, "(a9,i2,a10,i2,1x,a4)", 0 };
static cilist io___1359 = { 0, 11, 0, fmtq, 0 };
static cilist io___1361 = { 0, 6, 0, 0, 0 };
static cilist io___1362 = { 0, 6, 0, 0, 0 };
static cilist io___1363 = { 0, 11, 0, "(a)", 0 };
static icilist io___1366 = { 0, nmq+12, 0, "(2i1)", 2, 1 };
static icilist io___1367 = { 0, nmq+12, 0, "(a1,i2,a1,i1)", 5, 1 };
static cilist io___1368 = { 0, 11, 0, "(a)", 0 };
static cilist io___1369 = { 0, 11, 0, "(a18,i1,a2)", 0 };
static cilist io___1370 = { 0, 11, 0, "(a18,i2,a2)", 0 };
static cilist io___1372 = { 0, 11, 0, "(a11,i1,a2)", 0 };
static cilist io___1373 = { 0, 11, 0, "(a11,i2,a2)", 0 };
static cilist io___1374 = { 0, 11, 0, "(a11,i3,a2)", 0 };
static cilist io___1376 = { 0, 11, 0, "(a)", 0 };
static cilist io___1377 = { 0, 11, 0, "(a)", 0 };
static cilist io___1378 = { 0, 11, 0, "(a)", 0 };
static cilist io___1379 = { 0, 11, 0, "(a)", 0 };
static cilist io___1380 = { 0, 11, 0, "(a)", 0 };
static cilist io___1381 = { 0, 11, 0, "(a)", 0 };
static cilist io___1383 = { 0, 11, 0, fmtq, 0 };
static cilist io___1384 = { 0, 11, 0, "(a)", 0 };
static cilist io___1385 = { 0, 11, 0, fmtq, 0 };
static cilist io___1386 = { 0, 11, 0, "(a)", 0 };
static cilist io___1387 = { 0, 11, 0, "(a)", 0 };
static cilist io___1388 = { 0, 11, 0, "(a)", 0 };
static cilist io___1389 = { 0, 11, 0, "(a)", 0 };
static cilist io___1390 = { 0, 11, 0, "(a)", 0 };
static cilist io___1391 = { 0, 11, 0, "(a)", 0 };
static cilist io___1392 = { 0, 11, 0, "(a)", 0 };
static cilist io___1393 = { 0, 11, 0, "(a)", 0 };
static cilist io___1394 = { 0, 11, 0, "(a)", 0 };
static cilist io___1395 = { 0, 11, 0, "(a)", 0 };
static cilist io___1396 = { 0, 11, 0, "(a)", 0 };
static cilist io___1397 = { 0, 11, 0, "(a)", 0 };
static cilist io___1398 = { 0, 11, 0, "(a)", 0 };
static cilist io___1399 = { 0, 11, 0, "(a)", 0 };
static cilist io___1400 = { 0, 11, 0, "(a)", 0 };
static cilist io___1401 = { 0, 11, 0, "(a)", 0 };
static cilist io___1402 = { 0, 11, 0, "(a)", 0 };
static cilist io___1403 = { 0, 11, 0, "(a16,i1,a14)", 0 };
static cilist io___1404 = { 0, 11, 0, "(a)", 0 };
static cilist io___1405 = { 0, 12, 1, 0, 0 };
static cilist io___1408 = { 0, 11, 0, "(a)", 0 };
static cilist io___1409 = { 0, 11, 0, "(a)", 0 };
static cilist io___1410 = { 0, 11, 0, "(a)", 0 };
static cilist io___1412 = { 0, 11, 0, "(a)", 0 };
static cilist io___1413 = { 0, 11, 0, "(a)", 0 };
static cilist io___1414 = { 0, 11, 0, "(a)", 0 };
static cilist io___1415 = { 0, 11, 0, "(a)", 0 };
static cilist io___1416 = { 0, 11, 0, "(a,2i1,a)", 0 };
static cilist io___1417 = { 0, 11, 0, "(a)", 0 };
static cilist io___1418 = { 0, 11, 0, "(a)", 0 };
static cilist io___1434 = { 0, 11, 0, "(a)", 0 };
static cilist io___1435 = { 0, 11, 0, "(a)", 0 };
static cilist io___1443 = { 0, 11, 0, "(a11,f5.1,a4)", 0 };
static cilist io___1444 = { 0, 11, 0, "(a)", 0 };
static cilist io___1445 = { 0, 11, 0, "(a)", 0 };
static cilist io___1446 = { 0, 11, 0, "(a)", 0 };
static cilist io___1447 = { 0, 11, 0, "(a)", 0 };
static cilist io___1448 = { 0, 11, 0, "(a)", 0 };
static cilist io___1449 = { 0, 6, 0, 0, 0 };
static cilist io___1450 = { 0, 6, 0, 0, 0 };
static cilist io___1451 = { 0, 15, 0, 0, 0 };
static cilist io___1452 = { 0, 11, 0, "(a)", 0 };
static cilist io___1453 = { 0, 11, 0, "(a)", 0 };
static cilist io___1454 = { 0, 11, 0, fmtq, 0 };
static cilist io___1455 = { 0, 11, 0, "(a)", 0 };
static cilist io___1456 = { 0, 11, 0, "(a)", 0 };
static cilist io___1457 = { 0, 11, 0, "(a)", 0 };
static cilist io___1458 = { 0, 14, 0, "(a9,i2,a10,i2,1x,a5)", 0 };
static cilist io___1459 = { 0, 6, 0, 0, 0 };
static cilist io___1460 = { 0, 6, 0, 0, 0 };
static cilist io___1461 = { 0, 6, 0, 0, 0 };
static cilist io___1462 = { 0, 15, 0, "(/,a)", 0 };
static cilist io___1463 = { 0, 15, 0, "(a)", 0 };
/* ccccccccccccccccccccccccc */
/* c */
/* c To Do */
/* c */
/* c Resolve disagreement in final poe for 1st system, compared with *.mx2 */
/* c Shift slurs on right- or left-shifted main notes (2/7/99) */
/* c Various end-of-input-block repeat problems (ick142.pmx). */
/* c Force multiplicity for un-beamed xtups. */
/* c Clef change at end of piece */
/* c Global "A" option to maximize "X" at a given time tick. */
/* c Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted */
/* c note. See trubl18.pmx */
/* c Tab character as space. */
/* c Clef interference with second line of music. */
/* c Add space for interferences between *different* lines of music? */
/* c Shift arpeggios, both automatic and manual. */
/* c Different musicsize for different instruments. */
/* c Spacing checks for accid's on left-shifted chord notes */
/* c Spacing checks for double dots */
/* c Allow forced line breaks w/o setting nsyst. */
/* c Cresc-Decresc. (Enhance MusiXTeX first?) */
/* c Dynamic Marks. */
/* c Bug with Voltas at line end (MusiXTeX problem?). */
/* c Subtle bug w/ slur hgt over line brk, see trubl15.pmx */
/* c Stem-end slurs. */
/* c Allow units in indentation. */
/* c Make inline TeX more context sensitive. */
/* c Werner's 4/2/98 problem with "o?" */
/* c Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. */
/* c converts e.g. "r2db" into "r2d", which might be wrong. */
/* c Werner's generalsignature problem with Key change and new transposition. */
/* c (wibug8.pmx) */
/* c Unequal xtuplets */
/* c Print both sets of bar #'s in tex file. */
/* c Make barlines invisible \def\xbar{\empty} , fix fbar. */
/* c Auto-tie slurs 'At' */
/* c Forced line break anywhere (e.g. at a mid-bar repeat). */
/* c Clef change at very start of file. */
/* c Tighten test for M as macro terminator. */
/* c Fix title so not separate limit on author length + composer length. */
/* c Arpeggios in xtups. */
/* c */
/* c mx10b */
/* c Option for instrument name at top center. Last item in P command: */
/* c P[n]c text is instrument name (use in parts) */
/* c P[n]cstuff text is stuff (up to 1st blank) */
/* c P[n]c"stuff with spaces" text is stuff with spaces */
/* c */
/* c Post version 1.43 */
/* c Reduced space rqmt for multiplicity-0 graces (no flag) */
/* c Removed last sepsym in centered whole-bar rests, fixes volta height bug. */
/* c */
/* c Version 1.43 */
/* c Fix spacing for end-of-line signature change. */
/* c Adjust left-shift of grace group for shifted accidentals. */
/* c Put in extra space for left-shifted accidentals. */
/* c Fix bug with dot-shift before accid-shift on chord note. */
/* c Space-check for right-shifted main notes. */
/* c Enable forcing stem direction of single notes in non-beamed xtups. */
/* c Disallow clef change after last note before end of input block (pmxa) */
/* c Print meter change before page break */
/* c increase length of strings for \titles macro */
/* c version 1.42 */
/* c Loosen up input syntax for "X" commands. Subroutine getx() */
/* c "B" and "P" in "X" commands */
/* c mx09b */
/* c Allow multiple rests at start of xtup */
/* c Add 64th rest */
/* c Fix xtup numbers over rests. (subroutine levrn) */
/* c Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. */
/* c c za / ( c a ... */
/* c Allow double dots to be shifted. */
/* c Fix spacing with double dotted notes; permit splitting small note. */
/* c Fix \dotted printout so it works with old compiler */
/* c mx08b */
/* c Automatic spaces if needed for shifted accidentals. */
/* c Some Dynamics */
/* c Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) */
/* c version 1.41 */
/* c Allow ":" as last char of path name */
/* c Dotted slurs "sb" */
/* c Continue bar numbering at movement break "L[integer]Mc" */
/* c mx07b */
/* c Whole-bar rests with double lines of music. Fixed all options ? */
/* c Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. */
/* c Option to suppress centering full-bar rests. "o" */
/* c mx06b */
/* c Shift accid on left-shifted chord note. */
/* c Rest as first note of xtup. */
/* c Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt */
/* c Allow Rb for single bar at movemnet break or end of piece. (islur(25)) */
/* c Change # of inst at a movement break. noinst is total # and must be used */
/* c in 1st movement. ninow is current. nspern(1,...,ninow) is current */
/* c staves/inst, nsperi(1,...,noinst) is original. rename tells whether to */
/* c reprint names in parindent at a movement break. Default is .false. */
/* c unless ninow changes, then .true. But can force either with r+/- as */
/* c option in 'M' */
/* c mx04b */
/* c Double-dotted notes, separate+beamed, main+chord, still no extra space. */
/* c ??? Don't shift slur ends on whole notes. */
/* c (pmxa) Write line number of error in pmxaerr.dat */
/* c mx02b */
/* c Admit "RD" before "/" (search for "rptfq2:" ) */
/* c In doslur, for multi-line staves, single notes, check forced stem dir'n */
/* c before setting stemup (used to set horiz offset). */
/* cccccccccccccccccccccccccccccc */
/* FYI /all/ differs in appearance in function ncmid */
/* cccccccccccc */
/* c islur cc */
/* cccccccccccc */
/* bit meaning */
/* 0 slur activity on this note */
/* 1 t-slur here. */
/* 2 force 0-slope beam starting on this note */
/* 3 Double dotted note! */
/* 4 grace before main note */
/* 5 left repeat */
/* 6 right repeat */
/* 7 start Volta */
/* 8 doublebar */
/* 9 end Volta */
/* 10 on=>endvoltabox */
/* 11 on=>clefchange */
/* 12-14 0=>treble, ... , 6=>bass */
/* 15 on=> start new block for clef change (maybe diff. voice) */
/* 16 literal TeX string */
/* 17 1=up, 0=down stem for single note (override) See bit 30! */
/* 18 if on, prohibit beaming */
/* 19 if on, full bar rest as pause */
/* 20 Beam multiplicity down-up */
/* 21 Forced multiplicity for any beam including xtups */
/* 22-24 Value of forced multiplicity */
/* 25 single barline at movement break */
/* 26 doubleBAR (see bits 5,6,8) */
/* 27-28 Forced beam fine-tune height (1 to 3) */
/* 29 Blank rest */
/* 30 If on, get stem dir'n from bit 17 */
/* 31 If on, suppress printing number with xtuplet starting here */
/* cccccccccccc */
/* c ipl cc */
/* cccccccccccc */
/* c 0-7 Location in list [0,200] */
/* 0-7 Unused */
/* 8 left offset main note one headwidth */
/* 9 right offset main note one headwidth */
/* 10 chord present? */
/* 11-16 Forced beam height adjustment (-30 to +30) */
/* 17-22 Forced beam slope adjustment (-30 to +30) */
/* 23-26 Slur index for Way-after grace. Inserted when slur is started. */
/* c 27 Unused? */
/* 27 5th bit for slur index for Way-after grace (100712) */
/* 28 key change: only in voice 1 */
/* 29 Grace after main note. (Type A) */
/* 30 In forced beam. Signals need to check beam heights */
/* 31 Grace way after main note. (stretch to next note, type W) */
/* cccccccccccc */
/* c iornq cc */
/* cccccccccccc */
/* 0 Ornament "(". Was user-defined horizontal slur shift on this note */
/* until 9/24/97; changed that to irest(21) */
/* 1-13 stmgx+Tupf._) */
/* 14 Down fermata, was F */
/* 15 Trill w/o "tr", was U */
/* 16-18 Editorial s,f,n */
/* 19-20 >^ */
/* 21 "?" for editorial accid, w/ or w/o s,f,n */
/* 22 Set if ihornb governs ornament height. Same in icrdorn. */
/* 23 Set in getorn if ANY note at time of this main note has ornament. */
/* This is ONLY used in beamstrt to signal whether to do more */
/* tests for whether ihornb is needed. (ihornb is only needed */
/* if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) */
/* (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. */
/* 24 Slur on after or way-after grace. Use as signal to START slur. */
/* 25 Tweak orn ht. Same in icrdorn for chord note */
/* 26 Insert user-defined space before this note (was 22) */
/* 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord */
/* 28 caesura or breath */
/* 29 blank barline (must be iv=1) (would have used islur but no room) */
/* 30 "Look-left" option for keyboard rest */
/* 31 Set if any note (main or chord) has cautionary accid, for space checks */
/* cccccccccccc */
/* c irest cc */
/* cccccccccccc */
/* 0 rest=1, no rest = 0 */
/* 1 There will be a vertical shift for number of this xtup */
/* 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' */
/* 7 There is a horizontal shift for xtup number */
/* 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 */
/* 14 Flip up/down-ness of xtup number */
/* 15 Single-voice, single note shift X(...)[p]S */
/* 16 Start single-voice, multinote shift with this note X(...)[p]: */
/* 17 End single-voice, multinote shift after this note. Enter symbol */
/* after note. X: */
/* 18 User-defined hardspace after last note of bar, *after* this note. */
/* Value still stored in udoff(ivx,nudoff(ivx)), not with other */
/* hardspaces in udsp, to avoid confusion with time checks. */
/* 19 Move the dot. Data stored in ndotmv,updot,rtdot */
/* 20 Set if right-shifted main or chord note here. Use for space checks. */
/* 21 User-defined hardspace in xtup */
/* 22 User-defined slur shift horizontal slur shift. */
/* 23 Set on last note before staff-jumping a beam. */
/* 24 Set on first note after staff-jumping a beam */
/* 25 Suppress rest centering. "ro" */
/* 26 Dynamic on this note */
/* 27 Set if left-shifted main or chord note here. Use for space checks. */
/* 28 Set if xtup starts on this note. */
/* 29 Set on lowest-voice note at same time as 1st note after jump-beam. */
/* 30 Set on note after end of jump-beam segment, to force new note group */
/* 31 Flag for cautionary accidental */
/* cccccccccccc */
/* c nacc cc */
/* cccccccccccc */
/* 0-1 0=no accid, 1=fl, 2=sh, 3=na */
/* 2 double */
/* 3 big */
/* 4-9 vertshift-32 */
/* 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) */
/* 17 Midi-only accidental */
/* 18 2:1 xtup */
/* 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. */
/* 20 Set on last note of each seg except last seg of single-slope beam. */
/* 21 Set on 1st note of each seg except 1st seg of single-slope beam. */
/* 22-26 If .ne.0, printed xtup number for xtup starting on this note. */
/* 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase */
/* multiplicity by 1 */
/* 28 Set on main note of chord if accidentals are ordered. */
/* 29 Tag for chordal accidental shift...means add to autoshifts. */
/* 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. */
/* If upstem|downstem, main is upper|lower member of 2nd */
/* Action is to interchange pitches only when notes are placed. */
/* cccccccccccc */
/* c mult cc */
/* cccccccccccc */
/* 0-3 Multiplicity+8 (mult= # of flags) */
/* 4 Set if slope adjustment for xtup bracket */
/* 5-9 16+slope adjustment */
/* 27 Stemlength override */
/* 28-30 New stem length. */
/* cccccccccccc */
/* c isdat1 cc */
/* cccccccccccc */
/* 13-17 iv */
/* 3-10 ip */
/* 11 start/stop switch */
/* 12 kv-1 */
/* 19-25 ichar(code$) */
/* 26 force direction? */
/* 27 forced dir'n = up if on, set in sslur; also */
/* final direction, set in doslur when beam is started, used on term. */
/* 28-31 ndxslur, set in doslur when beam is started, used on term. */
/* cccccccccccc */
/* c isdat2 cc */
/* cccccccccccc */
/* 0 Chord switch. Not set on main note. */
/* 1-2 left/right notehead shift. Set only for chord note. */
/* 3 tie positioning */
/* 4 dotted slur */
/* 6-11 voff1 1-63 => -31...+31 */
/* 12-18 hoff1 1-127 => -6.3...+6.3 */
/* 19-25 nolev */
/* 26 \sluradjust (p+s) */
/* 27 \nosluradjust (p-s) */
/* 28 \tieadjust (p+t) */
/* 29 \notieadjust (p-t) */
/* cccccccccccc */
/* c isdat3 cc */
/* cccccccccccc */
/* 0 set if midslur (at least one argument) */
/* 1 set if curve (2 more args) */
/* 2-7 32+first arg (height correction) (1st arg may be negative) */
/* 8-10 second arg (initial slope) */
/* 11-13 third arg (closing slope) */
/* 14-21 tie level for use in LineBreakTies */
/* 22-29 ncm for use in LineBreakTies */
/* cccccccccccc */
/* c isdat4 cc Set these all at turn-on using s option */
/* cccccccccccc */
/* 0-5 Linebreak seg 1 voff 1-63 => -31...+31 */
/* 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 */
/* 16-21 Linebreak seg 2 voff 1-63 => -31...+31 */
/* 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 */
/* cccccccccccc */
/* icrdat c */
/* cccccccccccc */
/* 0-7 ip within voice */
/* 8-11 ivx (together with 28th bit) */
/* 12-18 note level */
/* 19 accidental? */
/* 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) */
/* 23 shift left */
/* 24 shift right */
/* 25 arpeggio start or stop */
/* 26 flag for moved dot (here, not icrdot, since this is always reset!) */
/* 27 Midi-only accidental */
/* 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices */
/* 29 Tag for accidental shift...means add to autoshifts. */
/* 31 Flag for cautionary accidental on chord note */
/* cccccccccccc */
/* icrdot c: */
/* cccccccccccc */
/* 0-6 10*abs(vertical dot shift in \internote) + 64 */
/* 7-13 10*abs(horizontal dot shift in \internote) + 64 */
/* 14-19 vert accidental shift-32 */
/* 20-26 20*(horiz accidental shift+3.2) */
/* 27-29 top-down level rank of chord note w/accid. Set in crdaccs. */
/* Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. */
/* ccccccccccccccccccccccccccccccc */
/* Parameter adjustments */
--poevec;
/* Function Body */
if (! (*optimize)) {
s_wsle(&io___1243);
e_wsle();
s_wsle(&io___1244);
do_lio(&c__9, &c__1, "Starting second PMX pass", (ftnlen)24);
e_wsle();
s_wsle(&io___1245);
e_wsle();
s_wsfe(&io___1246);
do_fio(&c__1, "Starting second PMX pass", (ftnlen)24);
e_wsfe();
}
++(*ncalls);
comlast_1.islast = *inlast;
commac_1.macuse = 0;
isyscnt = 0;
all_1.stemmax = 8.2f;
all_1.stemmin = 3.9f;
all_1.stemlen = 6.f;
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)all_1.sq = *(unsigned char *)&ch__1[0];
comignorenats_1.ignorenats = FALSE_;
combc_1.bcspec = TRUE_;
comas3_1.topmods = FALSE_;
ismbr = FALSE_;
s_rsfe(&io___1249);
do_fio(&c__1, basenameq, (ftnlen)44);
e_rsfe();
s_rsle(&io___1251);
do_lio(&c__3, &c__1, (char *)&lbase, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___1253);
do_lio(&c__4, &c__1, (char *)&comask_1.fbar, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&comask_1.wheadpt, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&etait, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&etatc, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&etacs1, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&etatop, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&etabot, (ftnlen)sizeof(real));
do_lio(&c__3, &c__1, (char *)&cominbot_1.inbothd, (ftnlen)sizeof(integer))
;
do_lio(&c__3, &c__1, (char *)&inhnoh, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&comtop_1.isig, (ftnlen)sizeof(integer));
e_rsle();
inbuff_1.ilbuf = 1;
inbuff_1.ipbuf = 0;
getset_(&all_1.nv, &noinst, &all_1.mtrnuml, &all_1.mtrdenl, &all_1.mtrnmp,
&all_1.mtrdnp, &xmtrnum0, &npages, &nsyst, &all_1.musicsize, &
comtop_1.fracindent, &istype0, comtop_1.inameq, comclefq_1.clefq,
all_1.sepsymq, pathnameq, &lpath, &comtop_1.isig0, (ftnlen)79, (
ftnlen)1, (ftnlen)1, (ftnlen)40);
if (commidi_1.ismidi) {
/* Initial key signature and meter for pickup bar */
/* 130313 Unless explicit miditranspose for all parts (to be dealt with later), */
/* want concert sig (isig0) here. K+n+m will have changed sig to isig */
/* call midievent('k',isig,0) */
/* 130316 */
/* call midievent('k',isig0,0) */
/* call midievent('k',midisig,0) */
/* Above is probably cosmetic */
/* call midievent('k',midisig,0) */
if (xmtrnum0 > comtol_1.tol) {
/* We have a pickup. Some tricky stuff to get a meter: */
xntrial = xmtrnum0;
for (ip2 = 0; ip2 <= 5; ++ip2) {
if ((r__1 = r_mod(&xntrial, &c_b807), dabs(r__1)) <
comtol_1.tol) {
goto L6;
}
xntrial *= 2;
/* L5: */
}
s_wsle(&io___1269);
do_lio(&c__9, &c__1, "Problem finding meter for pickup bar", (
ftnlen)36);
e_wsle();
xntrial = 1.f;
ip2 = 0;
L6:
i__1 = i_nint(&xntrial);
i__2 = pow_ii(&c__2, &ip2) * all_1.mtrdenl;
midievent_("m", &i__1, &i__2, (ftnlen)1);
} else {
/* No pickup, enter the starting meter */
midievent_("m", &all_1.mtrnuml, &all_1.mtrdenl, (ftnlen)1);
}
}
/* Set musicsize from value passed in common, due to possible reset by S[n]m16 */
all_1.musicsize = commus_1.musize;
s_rsle(&io___1270);
do_lio(&c__3, &c__1, (char *)&npages, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&comtop_1.widthpt, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&comtop_1.height, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&comtop_1.hoffpt, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&comtop_1.voffpt, (ftnlen)sizeof(real));
do_lio(&c__3, &c__1, (char *)&nsyst, (ftnlen)sizeof(integer));
i__1 = npages;
for (ipa = 1; ipa <= i__1; ++ipa) {
do_lio(&c__3, &c__1, (char *)&comnotes_1.nsystp[ipa - 1], (ftnlen)
sizeof(integer));
do_lio(&c__4, &c__1, (char *)&xnsttop[ipa - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&xintstaff[ipa - 1], (ftnlen)sizeof(real)
);
}
do_lio(&c__3, &c__1, (char *)&iauto, (ftnlen)sizeof(integer));
e_rsle();
/* If default width ever changes, must adjust this stmt. */
slfac1 = 2.98156f / comtop_1.widthpt;
all_1.figbass = FALSE_;
s_rsle(&io___1276);
do_lio(&c__3, &c__1, (char *)&ifig, (ftnlen)sizeof(integer));
e_rsle();
if (ifig == 1) {
all_1.figbass = TRUE_;
o__1.oerr = 0;
o__1.ounit = 14;
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);
s_wsfe(&io___1278);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "def";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 8, a__1[3] = "fixdrop{";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 7, a__1[5] = "advance";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 10, a__1[7] = "sysno by 1";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 6, a__1[9] = "ifcase";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 6, a__1[11] = "sysno%";
s_cat(ch__2, a__1, i__3, &c__12, (ftnlen)46);
do_fio(&c__1, ch__2, (ftnlen)46);
e_wsfe();
}
comget_1.lastchar = FALSE_;
ibcoff = 0;
if (xmtrnum0 > 0.f) {
ibcoff = -1;
}
o__1.oerr = 0;
o__1.ounit = 11;
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);
/* vshrink for the first page is calculated in topfile, */
/* and if true set interstaff=10. vshrink affects Titles. */
/* Must also save vshrink for page ending. */
topfile_(basenameq, &lbase, &all_1.nv, comclefq_1.clefq, &noinst, &
all_1.musicsize, xintstaff, &all_1.mtrnmp, &all_1.mtrdnp, &
vshrink, &comask_1.fbar, &comslur_1.fontslur, (ftnlen)44, (ftnlen)
1);
/* ninow is working value of # of instruments. noinst is max #, and # at start. */
comnotes_1.ninow = noinst;
/* Save original printed meter in case movement breaks */
comget_1.movnmp = all_1.mtrnmp;
comget_1.movdnp = all_1.mtrdnp;
if (comlast_1.islast && all_1.figbass && all_1.musicsize == 16) {
s_wsfe(&io___1281);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 3, a__2[1] = "def";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 8, a__2[3] = "figfont{";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 9, a__2[5] = "eightrm}%";
s_cat(ch__3, a__2, i__4, &c__6, (ftnlen)23);
do_fio(&c__1, ch__3, (ftnlen)23);
e_wsfe();
}
if (comlast_1.islast && comligfont_1.isligfont) {
if (all_1.musicsize == 16) {
s_wsfe(&io___1282);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 4, a__3[1] = "font";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 20, a__3[3] = "ligfont=cmrj at 8pt%";
s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)26);
do_fio(&c__1, ch__4, (ftnlen)26);
e_wsfe();
} else {
s_wsfe(&io___1283);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 4, a__3[1] = "font";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 21, a__3[3] = "ligfont=cmrj at 10pt%";
s_cat(ch__5, a__3, i__5, &c__4, (ftnlen)27);
do_fio(&c__1, ch__5, (ftnlen)27);
e_wsfe();
}
}
lenbeat = ifnodur_(&all_1.mtrdenl, "x", (ftnlen)1);
if (all_1.mtrdenl == 2) {
lenbeat = 16;
}
all_1.lenb1 = all_1.mtrnuml * lenbeat;
if (all_1.mtrdenl == 2) {
all_1.lenb1 <<= 1;
}
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &combeam_1.ibmtyp, &ibmrep);
r__1 = xmtrnum0 * lenbeat;
all_1.lenb0 = i_nint(&r__1);
if (all_1.mtrdenl == 2) {
all_1.lenb0 <<= 1;
}
if (all_1.lenb0 != 0) {
if (comlast_1.islast) {
s_wsfe(&io___1286);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 7, a__3[1] = "advance";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 11, a__3[3] = "barno by -1";
s_cat(ch__6, a__3, i__5, &c__4, (ftnlen)20);
do_fio(&c__1, ch__6, (ftnlen)20);
e_wsfe();
}
all_1.lenbar = all_1.lenb0;
} else {
all_1.lenbar = all_1.lenb1;
}
/* Initialize full-program variables */
comask_1.fixednew = 0.f;
comask_1.scaldold = 0.f;
comget_1.fintstf = -1.f;
comget_1.gintstf = 1.f;
comas2_1.nasksys = 0;
combibarcnt_1.ibarcnt = 0;
all_1.iline = 0;
comget_1.movbrk = 0;
isystpg = 0;
comnotes_1.ipage = 1;
all_1.iccount = 128;
comas3_1.iask = 0;
nhstot = 0;
comnsp_2.nb = 1;
if (! (*optimize)) {
jprntb = 81;
}
comtop_1.idsig = 0;
/* Next 5 are raise-barno parameters. irzbnd is integer part of default level. */
comsln_1.irzbnd = 3;
if (comtop_1.isig == 3 && *(unsigned char *)&comclefq_1.clefq[all_1.nv -
1] == 't') {
comsln_1.irzbnd = 4;
}
comsln_1.is1n1 = 0;
comsln_1.isnx = 0;
comslur_1.slurcurve = 0.f;
/* 111109 Made global rather than per gulp */
comdyn_1.ndyn = 0;
compoi_1.ispoi = FALSE_;
slint = FALSE_;
lrptpend = FALSE_;
comget_1.rptnd1 = FALSE_;
*(unsigned char *)comget_1.rptfq2 = 'E';
comget_1.rptprev = FALSE_;
onvolt = FALSE_;
comnsp_2.flgndb = FALSE_;
comget_1.fbon = FALSE_;
comnotes_1.shifton = FALSE_;
comget_1.ornrpt = FALSE_;
comnotes_1.setis = FALSE_;
comarp_1.lowdot = FALSE_;
comnvi_1.rename = FALSE_;
comnotes_1.nobar1 = FALSE_;
comget_1.equalize = FALSE_;
comlast_1.usevshrink = TRUE_;
comslur_1.wrotepsslurdefaults = FALSE_;
comnotes_1.optlinebreakties = FALSE_;
comnotes_1.headerspecial = FALSE_;
/* vshrink is initialized in topfile */
comget_1.stickys = FALSE_;
/* ixrest = 1 or 2 if xtup has started with a rest */
for (commvl_1.ivx = 1; commvl_1.ivx <= 24; ++commvl_1.ivx) {
strtmid_1.ixrest[commvl_1.ivx - 1] = 0;
comfig_1.fullsize[commvl_1.ivx - 1] = 1.f;
/* Set legacy note level to middle c as default */
comnotes_1.ndlev[commvl_1.ivx - 1] = 29;
comnotes_1.ndlev[commvl_1.ivx + 23] = 29;
/* L1: */
}
comnotes_1.npreslur = 0;
nhssys = 0;
comslur_1.listslur = 0;
for (i__ = 1; i__ <= 202; ++i__) {
all_1.isdat1[i__ - 1] = 0;
all_1.isdat2[i__ - 1] = 0;
/* L31: */
}
all_1.nsdat = 0;
/* Initialize flag for figures in any other voice than 1 */
comfig_1.ivxfig2 = 0;
/* Initialize for loop over gulps */
all_1.firstgulp = TRUE_;
/* Start a gulp */
L30:
loop = TRUE_;
comnotes_1.notcrd = TRUE_;
combjmp_1.isbjmp = FALSE_;
combjmp_1.isbj2 = FALSE_;
comfb_1.autofbon = FALSE_;
comfb_1.tautofb = 0.f;
all_1.nbars = 0;
comfig_1.nfigs[0] = 0;
comfig_1.nfigs[1] = 0;
comgrace_1.ngrace = 0;
comtrill_1.ntrill = 0;
comtrill_1.ncrd = 0;
comtrill_1.nudorn = 0;
comgrace_1.nlit = 0;
comgrace_1.nvolt = 0;
comgrace_1.ibarmbr = 0;
comudsp_1.nudsp = 0;
/* ndyn = 0 ! 111109 */
comdyn_1.ntxtdyn = 0;
comcb_1.nbc = 0;
comarpshift_1.numarpshift = 0;
for (i__ = 1; i__ <= 37; ++i__) {
comgrace_1.graspace[i__ - 1] = 0.f;
/* L3: */
}
/* Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. */
/* and also if nv increases in an 'M' directive. */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
newvoice_(&all_1.iv, comclefq_1.clefq + (all_1.iv - 1), &c_false, (
ftnlen)1);
/* L4: */
}
/* Check if endsymbol was set earlier */
if (comget_1.rptnd1) {
comget_1.rptnd1 = FALSE_;
*(unsigned char *)comget_1.rptfq2 = *(unsigned char *)comget_1.rptfq1;
} else {
/* Only use if movbrk>0, to signal default ('RD') */
*(unsigned char *)comget_1.rptfq2 = 'E';
}
all_1.iv = 1;
commvl_1.ivx = 1;
L2:
if (loop) {
/* Within this loop, nv voices are filled up for the duration of the block. */
/* On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) */
/* nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). */
/* nbars is for this input block. */
/* Only at the beginning of an input block will there be a possible mtr change, */
/* signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) */
getnote_(&loop);
if (comget_1.lastchar) {
goto L40;
}
goto L2;
}
/* Finished an input block (gulp). */
if (commidi_1.ismidi) {
/* Put rests into midi array for 2nd lines that were not used in this gulp. */
i__1 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__1; ++all_1.iv) {
if (commidi_1.twoline[all_1.iv - 1] && commvl_1.nvmx[all_1.iv - 1]
== 1) {
if (all_1.firstgulp && all_1.lenb0 != 0) {
r__1 = (all_1.nbars - 1.f) * all_1.lenbar + all_1.lenb0;
addmidi_(&commidi_1.midchan[all_1.iv + 23], &c__0, &c__0,
&c__0, &r__1, &c_true, &c_false);
} else {
r__1 = all_1.nbars * 1.f * all_1.lenbar;
addmidi_(&commidi_1.midchan[all_1.iv + 23], &c__0, &c__0,
&c__0, &r__1, &c_true, &c_false);
}
}
/* L60: */
}
}
comgrace_1.nvolt = 0;
for (all_1.iv = 1; all_1.iv <= 24; ++all_1.iv) {
comudsp_1.nudoff[all_1.iv - 1] = 0;
comcc_1.ndotmv[all_1.iv - 1] = 0;
/* L28: */
}
/* Put stuff at top of p.1. Must wait until now to have read title info. */
if (combibarcnt_1.ibarcnt == 0) {
puttitle_(&inhnoh, &xnsttop[comnotes_1.ipage - 1], &etatop, all_1.sq,
&etait, &etatc, &etacs1, &all_1.nv, &vshrink, all_1.sepsymq, (
ftnlen)1, (ftnlen)1);
if (comnotes_1.headerspecial) {
s_wsfe(&io___1296);
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__6[0] = 1, a__4[0] = ch__1;
i__6[1] = 28, a__4[1] = "special{header=psslurs.pro}%";
s_cat(ch__7, a__4, i__6, &c__2, (ftnlen)29);
do_fio(&c__1, ch__7, (ftnlen)29);
e_wsfe();
}
/* Write special header for first page */
}
i__1 = all_1.nbars;
for (all_1.ibar = 1; all_1.ibar <= i__1; ++all_1.ibar) {
++combibarcnt_1.ibarcnt;
comask_1.bar1syst = combibarcnt_1.ibarcnt == iauto;
/* Computing MAX */
r__1 = combibarcnt_1.ibarcnt + .001f + ibcoff;
i__2 = 0, i__7 = (integer) r_lg10(&r__1);
ndig = max(i__2,i__7);
if (comlast_1.islast) {
ci__1.cierr = 0;
ci__1.ciunit = 11;
/* Writing concatenation */
i__8[0] = 6, a__5[0] = "(a11,i";
i__2 = ndig + 50;
chax_(ch__1, (ftnlen)1, &i__2);
i__8[1] = 1, a__5[1] = ch__1;
i__8[2] = 1, a__5[2] = ")";
ci__1.cifmt = (s_cat(ch__8, a__5, i__8, &c__3, (ftnlen)8), ch__8);
s_wsfe(&ci__1);
do_fio(&c__1, "% Bar count", (ftnlen)11);
i__7 = combibarcnt_1.ibarcnt + ibcoff;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
e_wsfe();
}
if (all_1.ibar != comgrace_1.ibarmbr) {
if (! (*optimize)) {
i__2 = combibarcnt_1.ibarcnt + ibcoff;
outbar_(&i__2, &jprntb);
}
} else {
if (! (*optimize)) {
s_wsfe(&io___1298);
do_fio(&c__1, " Multibar rest, bars", (ftnlen)20);
i__2 = combibarcnt_1.ibarcnt + ibcoff;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "-", (ftnlen)1);
i__7 = combibarcnt_1.ibarcnt + ibcoff + comgrace_1.mbrest - 1;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___1299);
do_fio(&c__1, " Multibar rest, bars", (ftnlen)20);
i__2 = combibarcnt_1.ibarcnt + ibcoff;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "-", (ftnlen)1);
i__7 = combibarcnt_1.ibarcnt + ibcoff + comgrace_1.mbrest - 1;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
e_wsfe();
jprntb = 0;
}
ibcoff = ibcoff + comgrace_1.mbrest - 1;
if (all_1.ibar == 1 && all_1.firstgulp && ! bit_test(all_1.islur[
0],5)) {
comgrace_1.xb4mbr = comstart_1.facmtr * all_1.musicsize;
}
/* The above may be he only case where the space-before option is used in \mbrest */
}
/* Move the read to after end-of-bar hardspace checks, so we get right poenom */
/* at end of a line. */
/* if (bar1syst) read(12,*) poenom */
/* Check for clef at start of bar. No slide yet. Also flags at end of prev. */
/* bar. This block is run at the start of every bar. May fail for flag at */
/* end of last bar. To account for necc. hardspaces, compute and store */
/* nhssys = # of hard spaces for this system */
/* hesk(nhssys) = elemskips avialable */
/* hpts(nhssys) = hard points needed, including notehead */
/* Here, merely insert placeholder into output. Later, when poe is computed, */
/* compute additional pts and store them in hpttot(1...nhstot). Finally in */
/* subroutine askfig, write true pts where placeholders are. */
ioff = 0;
if (all_1.ibar > 1) {
ioff = all_1.nib[(all_1.ibar - 1) * 24 - 24];
}
clchb = bit_test(all_1.islur[(ioff + 1) * 24 - 24],15);
putmbr = FALSE_;
if (ismbr) {
if (clchb) {
/* Clef change and multi-bar rest coming up. Kluge to get space at end of rest. */
s_wsfe(&io___1303);
/* Writing concatenation */
i__9[0] = 1, a__6[0] = all_1.sq;
i__9[1] = 3, a__6[1] = "let";
i__9[2] = 1, a__6[2] = all_1.sq;
i__9[3] = 4, a__6[3] = "mbrt";
i__9[4] = 1, a__6[4] = all_1.sq;
i__9[5] = 6, a__6[5] = "mbrest";
i__9[6] = 1, a__6[6] = all_1.sq;
i__9[7] = 3, a__6[7] = "def";
i__9[8] = 1, a__6[8] = all_1.sq;
i__9[9] = 14, a__6[9] = "mbrest#1#2#3{%";
s_cat(ch__9, a__6, i__9, &c__10, (ftnlen)35);
do_fio(&c__1, ch__9, (ftnlen)35);
e_wsfe();
s_wsfe(&io___1304);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 13, a__4[1] = "mbrt{#1}{#2}{";
s_cat(ch__10, a__4, i__6, &c__2, (ftnlen)14);
do_fio(&c__1, ch__10, (ftnlen)14);
r__1 = all_1.musicsize * .55f;
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
/* Writing concatenation */
i__10[0] = 1, a__7[0] = "}";
i__10[1] = 1, a__7[1] = all_1.sq;
i__10[2] = 6, a__7[2] = "global";
i__10[3] = 1, a__7[3] = all_1.sq;
i__10[4] = 3, a__7[4] = "let";
i__10[5] = 1, a__7[5] = all_1.sq;
i__10[6] = 6, a__7[6] = "mbrest";
i__10[7] = 1, a__7[7] = all_1.sq;
i__10[8] = 6, a__7[8] = "mbrt}%";
s_cat(ch__4, a__7, i__10, &c__9, (ftnlen)26);
do_fio(&c__1, ch__4, (ftnlen)26);
e_wsfe();
}
ismbr = FALSE_;
putmbr = TRUE_;
}
if (all_1.ibar == comgrace_1.ibarmbr) {
ismbr = TRUE_;
}
/* Set flag here so at start of next bar, if there's a clef change, can add space */
/* after the mbr with the above kluge */
if (! (clchb || comnsp_2.flgndb)) {
goto L23;
}
/* Must check available space */
ptsndb = 0.f;
/* Zero out block signal */
if (clchb) {
all_1.islur[(ioff + 1) * 24 - 24] = bit_clear(all_1.islur[(ioff +
1) * 24 - 24],15);
}
/* In this loop, we determine how much hardspace is needed (if any) */
/* 9/7/97 Note that for last bar in input block, if number of lines of */
/* music decreases in new block, highest numbered ones won't be checked */
/* since the loop below covers the new nvmx(iv), not necessarily the old */
/* one. */
/* 4/18/98 Apparently nmxsav was a solution to the above problem */
i__2 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__2; ++all_1.iv) {
i__7 = comnsp_2.nvmxsav[all_1.iv - 1];
for (kv = 1; kv <= i__7; ++kv) {
commvl_1.ivx = comnsp_2.ivmxsav[all_1.iv + kv * 24 - 25];
ptsndv = comnsp_2.flgndv[commvl_1.ivx - 1] * comask_1.wheadpt;
ioff = 0;
if (all_1.ibar > 1) {
ioff = all_1.nib[commvl_1.ivx + (all_1.ibar - 1) * 24 -
25];
ip = ioff;
if (all_1.ibar > 2) {
ip = ioff - all_1.nib[commvl_1.ivx + (all_1.ibar - 2)
* 24 - 25];
}
/* prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) */
comnsp_2.prevtn[commvl_1.ivx - 1] = all_1.tnote[
comipl2_1.ipl2[commvl_1.ivx + ip * 24 - 25] - 1];
/* If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. */
}
/* Only allow clef changes when ivx <= nv */
if (commvl_1.ivx <= all_1.nv) {
clchv[all_1.iv - 1] = clchb && bit_test(all_1.islur[
all_1.iv + (ioff + 1) * 24 - 25],11);
if (clchv[all_1.iv - 1]) {
/* Clef change in this voice. Turn off signal. Get space avail. */
all_1.islur[all_1.iv + (ioff + 1) * 24 - 25] =
bit_clear(all_1.islur[all_1.iv + (ioff + 1) *
24 - 25],11);
if ((r__1 = comnsp_2.prevtn[all_1.iv - 1] -
comnsp_2.space[comnsp_2.nb - 1], dabs(r__1)) <
comtol_1.tol) {
ptsndv += combmh_1.clefend * comask_1.wheadpt;
}
}
}
/* Computing MAX */
r__1 = ptsndb, r__2 = ptsndv + comask_1.wheadpt *
spfacs_1.xspfac;
ptsndb = dmax(r__1,r__2);
/* L16: */
}
}
/* ???? where is nb set??? nb probably in left over from makeabar */
r__1 = comnsp_2.space[comnsp_2.nb - 1] * squez[comnsp_2.nb - 1];
esk = feon_(&r__1);
ptsdflt = esk * comask_1.poenom - comask_1.wheadpt;
/* if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then */
if ((ptsndb > ptsdflt || comnsp_2.ptsgnd > 0.f) && comget_1.movbrk ==
0 && ! putmbr) {
/* Must ADD hardspace! So put in a placeholder, and store params for later. */
if (comlast_1.islast) {
s_wsfe(&io___1313);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 18, a__4[1] = "xardspace{ pt}%";
s_cat(ch__11, a__4, i__6, &c__2, (ftnlen)19);
do_fio(&c__1, ch__11, (ftnlen)19);
e_wsfe();
}
++nhssys;
if (ptsndb - ptsdflt > comnsp_2.ptsgnd - comask_1.poenom *
comnsp_2.eskgnd) {
hesk[nhssys - 1] = esk;
hpts[nhssys - 1] = ptsndb + comask_1.wheadpt;
} else {
hesk[nhssys - 1] = comnsp_2.eskgnd;
hpts[nhssys - 1] = comnsp_2.ptsgnd + comask_1.wheadpt;
}
comask_1.fixednew += hpts[nhssys - 1];
comask_1.scaldold += hesk[nhssys - 1];
}
if (clchb) {
i__7 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__7; ++all_1.iv) {
if (clchv[all_1.iv - 1]) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 6, a__4[1] = "znotes";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 7;
i__2 = all_1.iv;
for (iiv = 2; iiv <= i__2; ++iiv) {
/* Writing concatenation */
i__6[0] = lnote, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = all_1.sepsymq + (iiv - 2);
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
++lnote;
/* L24: */
}
/* Recompute ioff since it will vary from voice to voice */
if (all_1.ibar == 1) {
ioff = 0;
} else {
ioff = all_1.nib[all_1.iv + (all_1.ibar - 1) * 24 -
25];
}
/* Must call clefsym to get nclef, even if there is a movement break */
clefsym_(&all_1.islur[all_1.iv + (ioff + 1) * 24 - 25],
fmtq, &lclef, &nclef, (ftnlen)24);
if (comget_1.movbrk == 0 && comlast_1.islast) {
s_wsfe(&io___1322);
/* Writing concatenation */
i__5[0] = lnote, a__3[0] = notexq;
i__5[1] = lclef, a__3[1] = fmtq;
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 3, a__3[3] = "en%";
s_cat(ch__12, a__3, i__5, &c__4, (ftnlen)107);
do_fio(&c__1, ch__12, lnote + lclef + 4);
e_wsfe();
}
wsclef_(&all_1.iv, &comnotes_1.ninow, comclefq_1.clefq, &
nclef, (ftnlen)1);
}
/* L17: */
}
if (comlast_1.islast) {
s_wsfe(&io___1323);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "pmxnewclefs";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
}
L23:
/* End of loop for end-of-bar hardspaces and non-movbrk clef symbol. */
if (comask_1.bar1syst) {
s_rsle(&io___1324);
do_lio(&c__4, &c__1, (char *)&comask_1.poenom, (ftnlen)sizeof(
real));
e_rsle();
}
/* Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) */
if (all_1.ibar == 1) {
islnow = all_1.islur[0];
iornqnow = all_1.iornq[24];
} else {
islnow = all_1.islur[(all_1.nib[(all_1.ibar - 1) * 24 - 24] + 1) *
24 - 24];
iornqnow = all_1.iornq[(all_1.nib[(all_1.ibar - 1) * 24 - 24] + 1)
* 24];
}
/* Check for R-symbols set at end of prior input block */
if (comget_1.movbrk == 0 && *(unsigned char *)comget_1.rptfq2 != 'E')
{
if (*(unsigned char *)comget_1.rptfq2 == 'D') {
islnow = bit_set(islnow,26);
} else if (*(unsigned char *)comget_1.rptfq2 == 'r') {
islnow = bit_set(islnow,6);
} else if (*(unsigned char *)comget_1.rptfq2 == 'd') {
islnow = bit_set(islnow,8);
} else if (*(unsigned char *)comget_1.rptfq2 == 'b') {
islnow = bit_set(islnow,25);
} else {
s_wsle(&io___1327);
e_wsle();
s_wsle(&io___1328);
do_lio(&c__9, &c__1, "Illegal symbol with \"R\" at end of in"
"put block:", (ftnlen)46);
do_lio(&c__9, &c__1, comget_1.rptfq2, (ftnlen)1);
e_wsle();
stop1_();
}
*(unsigned char *)comget_1.rptfq2 = 'E';
}
if ((islnow & 352) != 0) {
/* Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set */
lrpt = bit_test(islnow,5);
rrpt = bit_test(islnow,6);
lrptpend = lrpt && comask_1.bar1syst;
if (lrpt && ! lrptpend) {
if (rrpt) {
if (comlast_1.islast) {
s_wsfe(&io___1331);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 18, a__4[1] = "setleftrightrepeat";
s_cat(ch__11, a__4, i__6, &c__2, (ftnlen)19);
do_fio(&c__1, ch__11, (ftnlen)19);
e_wsfe();
}
comask_1.fixednew = comask_1.fixednew + comask_1.wheadpt *
spfacs_1.lrrptfac - .4f;
} else {
if (comlast_1.islast) {
s_wsfe(&io___1332);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 13, a__4[1] = "setleftrepeat";
s_cat(ch__10, a__4, i__6, &c__2, (ftnlen)14);
do_fio(&c__1, ch__10, (ftnlen)14);
e_wsfe();
}
comask_1.fixednew = comask_1.fixednew + comask_1.wheadpt *
spfacs_1.rptfac - .4f;
}
} else if (rrpt) {
if (comlast_1.islast) {
s_wsfe(&io___1333);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 14, a__4[1] = "setrightrepeat";
s_cat(ch__14, a__4, i__6, &c__2, (ftnlen)15);
do_fio(&c__1, ch__14, (ftnlen)15);
e_wsfe();
}
comask_1.fixednew = comask_1.fixednew + comask_1.wheadpt *
spfacs_1.rptfac - .4f;
} else if (bit_test(islnow,8)) {
if (comlast_1.islast) {
s_wsfe(&io___1334);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 12, a__4[1] = "setdoublebar";
s_cat(ch__15, a__4, i__6, &c__2, (ftnlen)13);
do_fio(&c__1, ch__15, (ftnlen)13);
e_wsfe();
}
comask_1.fixednew = comask_1.fixednew + comask_1.wheadpt *
spfacs_1.dbarfac - .4f;
}
} else if (bit_test(islnow,26)) {
/* doubleBAR */
if (comlast_1.islast) {
s_wsfe(&io___1335);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 12, a__4[1] = "setdoubleBAR";
s_cat(ch__15, a__4, i__6, &c__2, (ftnlen)13);
do_fio(&c__1, ch__15, (ftnlen)13);
e_wsfe();
}
comask_1.fixednew = comask_1.fixednew + comask_1.wheadpt *
spfacs_1.ddbarfac - .4f;
} else if (bit_test(iornqnow,29)) {
/* no bar line */
/* -- if (islast) write(11,'(a)')sq//'setzalaligne' */
/* ++ */
if (comlast_1.islast) {
if (comget_1.movbrk == 0) {
s_wsfe(&io___1336);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 12, a__4[1] = "setzalaligne";
s_cat(ch__15, a__4, i__6, &c__2, (ftnlen)13);
do_fio(&c__1, ch__15, (ftnlen)13);
e_wsfe();
} else {
/* Encountered "Rz" at start of input block at start of new movement, Must */
/* use newmovement macro with arg 4 rather than setzalaligne, since former */
/* already redefines stoppiece. */
*(unsigned char *)comget_1.rptfq2 = 'z';
}
}
/* ++ */
comask_1.fixednew += -.4f;
}
/* 1st and 2nd endings */
svolta = bit_test(islnow,7);
evolta = bit_test(islnow,9);
if (evolta) {
if (bit_test(islnow,10)) {
if (comlast_1.islast) {
s_wsfe(&io___1339);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "endvoltabox";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1340);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "endvolta";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
}
onvolt = FALSE_;
}
if (svolta) {
++comgrace_1.nvolt;
lvoltxt = i_indx(comgrace_1.voltxtq + (comgrace_1.nvolt - 1) * 20,
" ", (ftnlen)20, (ftnlen)1) - 1;
if (lvoltxt == 1) {
if (comlast_1.islast) {
s_wsfe(&io___1342);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 8, a__3[1] = "Setvolta";
i__5[2] = 1, a__3[2] = comgrace_1.voltxtq + (
comgrace_1.nvolt - 1) * 20;
i__5[3] = 1, a__3[3] = "%";
s_cat(ch__17, a__3, i__5, &c__4, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1343);
/* Writing concatenation */
i__11[0] = 1, a__8[0] = all_1.sq;
i__11[1] = 8, a__8[1] = "Setvolta";
i__11[2] = 1, a__8[2] = "{";
i__11[3] = lvoltxt, a__8[3] = comgrace_1.voltxtq + (
comgrace_1.nvolt - 1) * 20;
i__11[4] = 2, a__8[4] = "}%";
s_cat(ch__18, a__8, i__11, &c__5, (ftnlen)32);
do_fio(&c__1, ch__18, lvoltxt + 12);
e_wsfe();
}
}
onvolt = TRUE_;
}
if (all_1.ibar > 1) {
ipnow = all_1.nib[(all_1.ibar - 1) * 24 - 24] + 1;
} else {
ipnow = 1;
}
iplnow = all_1.ipl[ipnow * 24 - 24];
if (comask_1.bar1syst) {
/* If listslur>0, then there is at least one slur or tie carried over the break */
ispstie = FALSE_;
if (comnotes_1.optlinebreakties && ! comslur_1.fontslur &&
comslur_1.listslur != 0 && comlast_1.islast) {
linebreakties_(all_1.isdat1, all_1.isdat2, all_1.isdat3,
all_1.isdat4, &all_1.nsdat, &ispstie, all_1.sepsymq, (
ftnlen)1);
}
++all_1.iline;
/* End an old system, Start a new system */
if (all_1.iline != 1) {
/* Not first line. */
/* Get corrected poe = points/elemskip for *previous* system */
wdpt = comtop_1.widthpt * (1 - comtop_1.fracindent);
poe = (wdpt - fsyst * all_1.musicsize - nbarss * .4f -
comask_1.fixednew) / (elsktot + comask_1.fbar *
nbarss - comask_1.scaldold);
++isyscnt;
poevec[isyscnt] = poe;
/* Transfer data for system into global arrays to hold until very end */
i__7 = comas2_1.nasksys;
for (ia = 1; ia <= i__7; ++ia) {
++comas3_1.iask;
comas3_1.ask[comas3_1.iask - 1] = comas2_1.wasksys[ia - 1]
/ poe - (r__1 = comas2_1.elasksys[ia - 1], dabs(
r__1));
/* Only admit negative ask if it was user-defined space, signalled by elask<=0. */
if (comas2_1.elasksys[ia - 1] > 0.f) {
comas3_1.ask[comas3_1.iask - 1] = r_dim(&comas3_1.ask[
comas3_1.iask - 1], &c_b762);
}
/* L9: */
}
i__7 = nhssys;
for (ia = 1; ia <= i__7; ++ia) {
++nhstot;
/* Computing MAX */
r__1 = hpts[ia - 1] - hesk[ia - 1] * poe;
comhsp_1.hpttot[nhstot - 1] = dmax(r__1,0.f);
/* L25: */
}
/* Reset counters for new system */
comask_1.scaldold = 0.f;
comask_1.fixednew = 0.f;
comas2_1.nasksys = 0;
nhssys = 0;
}
/* End of if block for first bar of non-first system. Still 1st bar, any system */
if (comlast_1.islast && all_1.figbass) {
s_wsfe(&io___1353);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "fixdrop%";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
++isystpg;
/* Try moving the next stmt way down, to fix a bug and get \eject printed at */
/* end of single-system page. */
/* if (isystpg .eq. nsystp(ipage)) isystpg = 0 */
s_rsle(&io___1354);
do_lio(&c__3, &c__1, (char *)&nbarss, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&elsktot, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&fsyst, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&frac, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&comeon_1.eonk, (ftnlen)sizeof(real))
;
do_lio(&c__4, &c__1, (char *)&comeon_1.ewmxk, (ftnlen)sizeof(real)
);
e_rsle();
if (all_1.iline > 1) {
comtop_1.fracindent = frac;
}
if (all_1.figbass) {
all_1.ifigdr[(all_1.iline << 1) - 2] = 4;
all_1.ifigdr[(all_1.iline << 1) - 1] = 4;
}
all_1.slfac = slfac1 * all_1.musicsize * elsktot;
if (all_1.iline != 1) {
/* For the line just _finished_, put figdrop in separate file. */
if (all_1.figbass) {
s_wsfe(&io___1356);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "figdrop=";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
do_fio(&c__1, (char *)&all_1.ifigdr[(all_1.iline - 1 << 1)
- 2], (ftnlen)sizeof(integer));
/* Writing concatenation */
i__8[0] = 1, a__5[0] = " ";
i__8[1] = 1, a__5[1] = all_1.sq;
i__8[2] = 8, a__5[2] = "figdtwo=";
s_cat(ch__19, a__5, i__8, &c__3, (ftnlen)10);
do_fio(&c__1, ch__19, (ftnlen)10);
do_fio(&c__1, (char *)&all_1.ifigdr[(all_1.iline - 1 << 1)
- 1], (ftnlen)sizeof(integer));
/* Writing concatenation */
i__12[0] = 1, a__9[0] = all_1.sq;
i__12[1] = 3, a__9[1] = "or%";
s_cat(ch__20, a__9, i__12, &c__2, (ftnlen)4);
do_fio(&c__1, ch__20, (ftnlen)4);
e_wsfe();
}
/* Check slurs in top staff for interference w/ barno. Only check when */
/* # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS */
/* keep track of ons and offs when |isig|<=3. */
r__1 = combibarcnt_1.ibarcnt + ibcoff + .01f;
ndigbn = (integer) r_lg10(&r__1) + 1;
comsln_1.isnx = 0;
if (ndigbn >= abs(comtop_1.isig) && comsln_1.is1n1 > 0) {
/* There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 */
/* Look for termination in remainder of this input block. If not found, */
/* just use is1n1. Remember, haven't slid down yet. */
ioff = 0;
if (all_1.ibar > 1) {
ioff = all_1.nib[commvl_1.ivmx[all_1.nv +
commvl_1.nvmx[all_1.nv - 1] * 24 - 25] + (
all_1.ibar - 1) * 24 - 25];
}
i__7 = all_1.nsdat;
for (isdat = 1; isdat <= i__7; ++isdat) {
if (igetbits_(&all_1.isdat1[isdat - 1], &c__5, &c__13)
== commvl_1.ivmx[all_1.nv + commvl_1.nvmx[
all_1.nv - 1] * 24 - 25] && ! bit_test(
all_1.isdat1[isdat - 1],11) && igetbits_(&
all_1.isdat1[isdat - 1], &c__7, &c__19) ==
comsln_1.is2n1) {
/* Found slur ending. Just check note height, can't do fine adjustments. */
/* is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) */
/* Computing MAX */
i__2 = comsln_1.is1n1, i__13 = igetbits_(&
all_1.isdat2[isdat - 1], &c__7, &c__19);
comsln_1.is1n1 = max(i__2,i__13);
goto L51;
}
/* L50: */
}
/* If exiting loop normally, did not find end of slur. c'est la vie. */
L51:
i__7 = ncmid_(&all_1.nv, &c__1) + 1 + comsln_1.irzbnd;
comsln_1.isnx = i_dim(&comsln_1.is1n1, &i__7);
if (comsln_1.isnx > 0) {
/* AHA! Slur likely to interfere with barno. */
/* Modified 090525 to use \bnrs */
slint = TRUE_;
s_copy(fmtq, "(a16,i1,a14)", (ftnlen)24, (ftnlen)12);
if (comsln_1.irzbnd + comsln_1.isnx > 9) {
s_copy(fmtq, "(a16,i2,a14)", (ftnlen)24, (ftnlen)
12);
}
if (comlast_1.islast) {
s_wsfe(&io___1359);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 3, a__3[1] = "def";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 11, a__3[3] = "raisebarno{";
s_cat(ch__21, a__3, i__5, &c__4, (ftnlen)16);
do_fio(&c__1, ch__21, (ftnlen)16);
i__7 = comsln_1.irzbnd + comsln_1.isnx;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(
integer));
/* Writing concatenation */
i__8[0] = 2, a__5[0] = ".5";
i__8[1] = 1, a__5[1] = all_1.sq;
i__8[2] = 11, a__5[2] = "internote}%";
s_cat(ch__10, a__5, i__8, &c__3, (ftnlen)14);
do_fio(&c__1, ch__10, (ftnlen)14);
e_wsfe();
}
/* if (islast) then */
/* if (isnx .le. 9) then */
/* write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' */
/* else */
/* write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' */
/* end if */
/* end if */
}
}
if (comget_1.movbrk > 0) {
/* movbrk = 0 */
/* Move the reset down, so can use movbrk>0 to stop extra meter prints. */
/* New movement. Redefine stoppiece, contpiece. These will be called either */
/* explicitly or as part of alaligne. */
/* indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. */
/* This is passed to \newmovement. */
if (*(unsigned char *)comget_1.rptfq2 == 'E') {
*(unsigned char *)comget_1.rptfq2 = 'D';
}
indsym = i_indx("Ddrbz", comget_1.rptfq2, (ftnlen)5, (
ftnlen)1) - 1;
*(unsigned char *)comget_1.rptfq2 = 'E';
/* Also check for Rd or Rr set the normal way */
if (bit_test(islnow,8)) {
indsym = 1;
} else if (bit_test(islnow,6)) {
indsym = 2;
}
if (indsym < 0) {
s_wsle(&io___1361);
e_wsle();
s_wsle(&io___1362);
do_lio(&c__9, &c__1, "Illegal end symbol before \"/\""
, (ftnlen)29);
e_wsle();
stop1_();
}
/* Check for continuation (no bar number reset) */
if (comlast_1.islast && comnotes_1.nobar1) {
s_wsfe(&io___1363);
/* Writing concatenation */
i__14[0] = 1, a__10[0] = all_1.sq;
i__14[1] = 7, a__10[1] = "advance";
i__14[2] = 1, a__10[2] = all_1.sq;
i__14[3] = 6, a__10[3] = "barno1";
i__14[4] = 1, a__10[4] = all_1.sq;
i__14[5] = 10, a__10[5] = "startbarno";
i__14[6] = 1, a__10[6] = all_1.sq;
i__14[7] = 6, a__10[7] = "barno%";
s_cat(ch__22, a__10, i__14, &c__8, (ftnlen)33);
do_fio(&c__1, ch__22, (ftnlen)33);
e_wsfe();
}
/* Per Rainer's suggestion, changing \nbinstruments via 3rd arg of \newmovement */
/* if (movgap .lt. 10) then */
/* if (islast) write(11,'(a12,2i1,a1)') */
/* * sq//'newmovement',movgap,indsym,'%' */
/* else */
/* if (islast) write(11,'(a13,i2,a1,i1,a1)') */
/* * sq//'newmovement{',movgap,'}',indsym,'%' */
/* end if */
if (comlast_1.islast) {
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "newmovement";
s_cat(nmq, a__4, i__6, &c__2, (ftnlen)40);
lnmq = 12;
if (comget_1.movgap < 10) {
lnmq = 14;
s_wsfi(&io___1366);
do_fio(&c__1, (char *)&comget_1.movgap, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&indsym, (ftnlen)sizeof(
integer));
e_wsfi();
} else {
lnmq = 17;
s_wsfi(&io___1367);
do_fio(&c__1, "{", (ftnlen)1);
do_fio(&c__1, (char *)&comget_1.movgap, (ftnlen)
sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
do_fio(&c__1, (char *)&indsym, (ftnlen)sizeof(
integer));
e_wsfi();
}
if (comnotes_1.ninow < 10) {
++lnmq;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = nmq + (lnmq - 1);
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comnotes_1.ninow, (ftnlen)
sizeof(integer));
e_wsfi();
} else {
lnmq += 4;
i__7 = lnmq - 4;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnmq - i__7;
ici__1.iciunit = nmq + i__7;
ici__1.icifmt = "(a1,i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
do_fio(&c__1, (char *)&comnotes_1.ninow, (ftnlen)
sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
}
++lnmq;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 1;
ici__1.iciunit = nmq + (lnmq - 1);
ici__1.icifmt = "(a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "%", (ftnlen)1);
e_wsfi();
s_wsfe(&io___1368);
do_fio(&c__1, nmq, lnmq);
e_wsfe();
}
/* Change generalmeter if necessary */
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
/* (Moved all name-writing to getnote, right when 'M' is detected) */
if (bit_test(iplnow,28)) {
/* Key signature at movement break */
iplnow = bit_clear(iplnow,28);
if (comtop_1.isig > 0) {
if (comlast_1.islast) {
s_wsfe(&io___1369);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 17, a__4[1] = "generalsignature{";
s_cat(ch__23, a__4, i__6, &c__2, (ftnlen)18);
do_fio(&c__1, ch__23, (ftnlen)18);
do_fio(&c__1, (char *)&comtop_1.isig, (ftnlen)
sizeof(integer));
do_fio(&c__1, "}%", (ftnlen)2);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1370);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 17, a__4[1] = "generalsignature{";
s_cat(ch__23, a__4, i__6, &c__2, (ftnlen)18);
do_fio(&c__1, ch__23, (ftnlen)18);
do_fio(&c__1, (char *)&comtop_1.isig, (ftnlen)
sizeof(integer));
do_fio(&c__1, "}%", (ftnlen)2);
e_wsfe();
}
}
if (comlast_1.islast && cominsttrans_1.laterinsttrans)
{
writesetsign_(&cominsttrans_1.ninsttrans,
cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &
cominsttrans_1.laterinsttrans);
}
}
if (comget_1.parmov >= -.1f) {
/* Resent paragraph indentation */
ipi = comget_1.parmov * comtop_1.widthpt + .1f;
if (ipi < 10) {
if (comlast_1.islast) {
s_wsfe(&io___1372);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "parindent ";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(
integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
} else if (ipi < 100) {
if (comlast_1.islast) {
s_wsfe(&io___1373);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "parindent ";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(
integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1374);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "parindent ";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(
integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
}
}
}
if (isystpg == 1) {
/* First line on a page (not 1st page, still first bar). Tidy up old page */
/* then eject. */
/* Removed this 5/13/01 as it was causing double endvoltas. This probably */
/* is only needed at the end in case there is no endvolta specified. */
/* if (onvolt) then */
/* c if (islast) write(11,'(a)')sq//'endvoltabox%' */
/* c onvolt = .false. */
/* end if */
/* Check for meter change at start of a new PAGE */
if (all_1.mtrnuml > 0) {
/* Meter change at start of a new page. Ugly repeated coding here. */
mtrnms = all_1.mtrnuml;
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &
combeam_1.ibmtyp, &ibmrep);
all_1.mtrnuml = mtrnms;
if (comget_1.movbrk == 0 && comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
}
/* Key signature change? */
if (bit_test(iplnow,28) && comget_1.movbrk == 0) {
/* Writing concatenation */
i__14[0] = 1, a__10[0] = all_1.sq;
i__14[1] = 4, a__10[1] = "xbar";
i__14[2] = 1, a__10[2] = all_1.sq;
i__14[3] = 10, a__10[3] = "addspace{-";
i__14[4] = 1, a__10[4] = all_1.sq;
i__14[5] = 14, a__10[5] = "afterruleskip}";
i__14[6] = 1, a__10[6] = all_1.sq;
i__14[7] = 17, a__10[7] = "generalsignature{";
s_cat(notexq, a__10, i__14, &c__8, (ftnlen)79);
lnote = 49;
if (comtop_1.isig < 0) {
/* Writing concatenation */
i__6[0] = 49, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "-";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 50;
}
if (comlast_1.islast) {
s_wsfe(&io___1376);
/* Writing concatenation */
i__8[0] = lnote, a__5[0] = notexq;
i__7 = abs(comtop_1.isig) + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__8[1] = 1, a__5[1] = ch__1;
i__8[2] = 2, a__5[2] = "}%";
s_cat(ch__24, a__5, i__8, &c__3, (ftnlen)82);
do_fio(&c__1, ch__24, lnote + 3);
e_wsfe();
}
if (comlast_1.islast && cominsttrans_1.laterinsttrans)
{
writesetsign_(&cominsttrans_1.ninsttrans,
cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &
cominsttrans_1.laterinsttrans);
}
if (comlast_1.islast && comignorenats_1.ignorenats) {
s_wsfe(&io___1377);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1378);
/* Writing concatenation */
i__9[0] = 1, a__6[0] = all_1.sq;
i__9[1] = 14, a__6[1] = "zchangecontext";
i__9[2] = 1, a__6[2] = all_1.sq;
i__9[3] = 10, a__6[3] = "addspace{-";
i__9[4] = 1, a__6[4] = all_1.sq;
i__9[5] = 14, a__6[5] = "afterruleskip}";
i__9[6] = 1, a__6[6] = all_1.sq;
i__9[7] = 10, a__6[7] = "zstoppiece";
i__9[8] = 1, a__6[8] = all_1.sq;
i__9[9] = 13, a__6[9] = "PMXbarnotrue%";
s_cat(ch__25, a__6, i__9, &c__10, (ftnlen)66);
do_fio(&c__1, ch__25, (ftnlen)66);
e_wsfe();
}
} else if (all_1.mtrnuml > 0 && comget_1.movbrk == 0) {
/* Meter change but no signature change */
if (comlast_1.islast) {
s_wsfe(&io___1379);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 14, a__1[1] = "xchangecontext";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 10, a__1[3] = "addspace{-";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 14, a__1[5] = "afterruleskip}";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 3, a__1[7] = "let";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 4, a__1[9] = "bnat";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 9, a__1[11] = "barnoadd%";
s_cat(ch__26, a__1, i__3, &c__12, (ftnlen)60);
do_fio(&c__1, ch__26, (ftnlen)60);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1380);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "def";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 9, a__1[3] = "barnoadd{";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 3, a__1[5] = "let";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 8, a__1[7] = "barnoadd";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 5, a__1[9] = "bnat}";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 11, a__1[11] = "zstoppiece%";
s_cat(ch__27, a__1, i__3, &c__12, (ftnlen)45);
do_fio(&c__1, ch__27, (ftnlen)45);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1381);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "stoppiece%";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
e_wsfe();
}
}
/* This is the key spot when vshrink is used. Value of vshrink here comes from */
/* just after the prior pagebreak, i.e., it is not affected by "Av" */
/* that may have been entered at this pagebreak, since that only affects usevshrink. */
/* So choose page *ending* (with or without \vfill) depending on old vshrink. Then */
/* check value of usevshrink to reset vshrink if necessary for the new page, where */
/* we have to set \interstaff and later call puttitle. */
/* Top of first page needs special treatment. For this we use */
/* novshrinktop, which was set in g1etnote on the first pass, since on */
/* second pass, vshrink at top of page one is dealt with in topfile, which is called */
/* *before* any reading in any "Av" at the top of the first input block. */
if (! vshrink) {
xnstbot = xnsttop[comnotes_1.ipage - 1] * etabot /
etatop;
if (xnstbot < 9.95f) {
s_copy(fmtq, "(a,f3.1,a)", (ftnlen)24, (ftnlen)10)
;
} else {
s_copy(fmtq, "(a,f4.1,a)", (ftnlen)24, (ftnlen)10)
;
}
if (comlast_1.islast) {
s_wsfe(&io___1383);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 5, a__4[1] = "vskip";
s_cat(ch__28, a__4, i__6, &c__2, (ftnlen)6);
do_fio(&c__1, ch__28, (ftnlen)6);
do_fio(&c__1, (char *)&xnstbot, (ftnlen)sizeof(
real));
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 10, a__3[1] = "Interligne";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 6, a__3[3] = "eject%";
s_cat(ch__23, a__3, i__5, &c__4, (ftnlen)18);
do_fio(&c__1, ch__23, (ftnlen)18);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1384);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 5, a__3[1] = "vfill";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 6, a__3[3] = "eject%";
s_cat(ch__15, a__3, i__5, &c__4, (ftnlen)13);
do_fio(&c__1, ch__15, (ftnlen)13);
e_wsfe();
}
}
++comnotes_1.ipage;
/* Now that page is ejected, compute new vshrink */
vshrink = xintstaff[comnotes_1.ipage - 1] > 20.f &&
comlast_1.usevshrink;
if (vshrink) {
comarp_1.xinsnow = 10.f;
} else {
comarp_1.xinsnow = xintstaff[comnotes_1.ipage - 1];
}
if (comget_1.fintstf > 0.f && comnotes_1.ipage > 1) {
comarp_1.xinsnow = comarp_1.xinsnow *
comget_1.fintstf / comget_1.gintstf;
comget_1.fintstf = -1.f;
}
if (comarp_1.xinsnow < 9.95f) {
s_copy(fmtq, "(a,f3.1,a)", (ftnlen)24, (ftnlen)10);
} else if (comarp_1.xinsnow < 99.95f) {
s_copy(fmtq, "(a,f4.1,a)", (ftnlen)24, (ftnlen)10);
} else {
s_copy(fmtq, "(a,f5.1,a)", (ftnlen)24, (ftnlen)10);
}
/* Vertical spacing parameters, then restart */
if (comlast_1.islast) {
s_wsfe(&io___1385);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "interstaff{";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
do_fio(&c__1, (char *)&comarp_1.xinsnow, (ftnlen)
sizeof(real));
/* Writing concatenation */
i__8[0] = 1, a__5[0] = "}";
i__8[1] = 1, a__5[1] = all_1.sq;
i__8[2] = 9, a__5[2] = "contpiece";
s_cat(ch__17, a__5, i__8, &c__3, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
e_wsfe();
}
/* Check for meter change at start of a new PAGE */
if (all_1.mtrnuml > 0) {
/* Meter change at start of a new page */
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &
combeam_1.ibmtyp, &ibmrep);
if (comget_1.movbrk == 0) {
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
if (all_1.mtrdnp > 0) {
if (comlast_1.islast) {
s_wsfe(&io___1386);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "newtimes2%";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)
11);
do_fio(&c__1, ch__17, (ftnlen)11);
e_wsfe();
}
if (all_1.ibar == comgrace_1.ibarmbr) {
comgrace_1.xb4mbr = comstart_1.facmtr *
all_1.musicsize;
}
}
}
}
/* If no real titles here, which there probably will never be, make vertical */
/* space at page top with \titles{...}. headlog=.false.<=>no real titles */
puttitle_(&inhnoh, &xnsttop[comnotes_1.ipage - 1], &
etatop, all_1.sq, &etait, &etatc, &etacs1, &
all_1.nv, &vshrink, all_1.sepsymq, (ftnlen)1, (
ftnlen)1);
if (comnotes_1.headerspecial) {
s_wsfe(&io___1387);
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__6[0] = 1, a__4[0] = ch__1;
i__6[1] = 28, a__4[1] = "special{header=psslurs.pro}%"
;
s_cat(ch__7, a__4, i__6, &c__2, (ftnlen)29);
do_fio(&c__1, ch__7, (ftnlen)29);
e_wsfe();
}
/* Write special header for first page */
} else {
/* First bar of system, not a new page, force line break */
if (bit_test(iplnow,28)) {
/* Signature change */
/* Writing concatenation */
i__14[0] = 1, a__10[0] = all_1.sq;
i__14[1] = 4, a__10[1] = "xbar";
i__14[2] = 1, a__10[2] = all_1.sq;
i__14[3] = 10, a__10[3] = "addspace{-";
i__14[4] = 1, a__10[4] = all_1.sq;
i__14[5] = 14, a__10[5] = "afterruleskip}";
i__14[6] = 1, a__10[6] = all_1.sq;
i__14[7] = 17, a__10[7] = "generalsignature{";
s_cat(notexq, a__10, i__14, &c__8, (ftnlen)79);
lnote = 49;
if (comtop_1.isig < 0) {
/* Writing concatenation */
i__6[0] = 49, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "-";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 50;
}
if (comlast_1.islast) {
s_wsfe(&io___1388);
/* Writing concatenation */
i__8[0] = lnote, a__5[0] = notexq;
i__7 = abs(comtop_1.isig) + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__8[1] = 1, a__5[1] = ch__1;
i__8[2] = 2, a__5[2] = "}%";
s_cat(ch__24, a__5, i__8, &c__3, (ftnlen)82);
do_fio(&c__1, ch__24, lnote + 3);
e_wsfe();
}
if (comlast_1.islast && cominsttrans_1.laterinsttrans)
{
writesetsign_(&cominsttrans_1.ninsttrans,
cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &
cominsttrans_1.laterinsttrans);
}
if (comlast_1.islast) {
s_wsfe(&io___1389);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 7, a__3[1] = "advance";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 8, a__3[3] = "barno-1%";
s_cat(ch__29, a__3, i__5, &c__4, (ftnlen)17);
do_fio(&c__1, ch__29, (ftnlen)17);
e_wsfe();
}
if (all_1.mtrnuml != 0) {
/* Meter+sig change, new line, may need mods if movement break here. */
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &
combeam_1.ibmtyp, &ibmrep);
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
if (comignorenats_1.ignorenats) {
s_wsfe(&io___1390);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)
12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
s_wsfe(&io___1391);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 14, a__1[1] = "xchangecontext";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 10, a__1[3] = "addspace{-";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 14, a__1[5] = "afterruleskip}";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 10, a__1[7] = "zstoppiece";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 12, a__1[9] = "PMXbarnotrue";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 10, a__1[11] = "contpiece%";
s_cat(ch__30, a__1, i__3, &c__12, (ftnlen)76);
do_fio(&c__1, ch__30, (ftnlen)76);
e_wsfe();
/* * 'addspace{-'//sq//'afterruleskip}'//sq//'def' */
/* * //sq//'writezbarno{}'//sq//'zalaligne%' */
s_wsfe(&io___1392);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 10, a__3[1] = "addspace{-";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 15, a__3[3] = "afterruleskip}%";
s_cat(ch__5, a__3, i__5, &c__4, (ftnlen)27);
do_fio(&c__1, ch__5, (ftnlen)27);
e_wsfe();
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
if (comignorenats_1.ignorenats) {
s_wsfe(&io___1393);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)
12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
s_wsfe(&io___1394);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 14, a__4[1] = "zchangecontext";
s_cat(ch__14, a__4, i__6, &c__2, (ftnlen)15);
do_fio(&c__1, ch__14, (ftnlen)15);
e_wsfe();
}
} else {
if (comlast_1.islast &&
comignorenats_1.ignorenats) {
s_wsfe(&io___1395);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1396);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 14, a__1[1] = "xchangecontext";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 10, a__1[3] = "addspace{-";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 14, a__1[5] = "afterruleskip}";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 10, a__1[7] = "zstoppiece";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 12, a__1[9] = "PMXbarnotrue";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 10, a__1[11] = "contpiece%";
s_cat(ch__30, a__1, i__3, &c__12, (ftnlen)76);
do_fio(&c__1, ch__30, (ftnlen)76);
e_wsfe();
}
/* * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// */
/* * sq//'writezbarno{}'//sq//'zalaligne%' */
}
} else if (all_1.mtrnuml == 0) {
/* No meter change */
if (comlast_1.islast) {
s_wsfe(&io___1397);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "alaligne";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
} else {
/* New meter, no new sig, end of line, not new page. */
/* \generalmeter{\meterfrac{3}{4}}% */
/* \xchangecontext\addspace{-\afterruleskip}% */
/* \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% */
/* \zchangecontext */
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &
combeam_1.ibmtyp, &ibmrep);
if (comget_1.movbrk == 0) {
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
if (all_1.mtrdnp > 0) {
if (comlast_1.islast) {
s_wsfe(&io___1398);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = all_1.sq;
i__3[1] = 3, a__1[1] = "let";
i__3[2] = 1, a__1[2] = all_1.sq;
i__3[3] = 4, a__1[3] = "bnat";
i__3[4] = 1, a__1[4] = all_1.sq;
i__3[5] = 8, a__1[5] = "barnoadd";
i__3[6] = 1, a__1[6] = all_1.sq;
i__3[7] = 3, a__1[7] = "def";
i__3[8] = 1, a__1[8] = all_1.sq;
i__3[9] = 9, a__1[9] = "barnoadd{";
i__3[10] = 1, a__1[10] = all_1.sq;
i__3[11] = 7, a__1[11] = "empty}%";
s_cat(ch__31, a__1, i__3, &c__12, (ftnlen)
40);
do_fio(&c__1, ch__31, (ftnlen)40);
e_wsfe();
s_wsfe(&io___1399);
/* Writing concatenation */
i__15[0] = 1, a__11[0] = all_1.sq;
i__15[1] = 14, a__11[1] = "xchangecontext"
;
i__15[2] = 1, a__11[2] = all_1.sq;
i__15[3] = 10, a__11[3] = "addspace{-";
i__15[4] = 1, a__11[4] = all_1.sq;
i__15[5] = 14, a__11[5] = "afterruleskip}"
;
i__15[6] = 1, a__11[6] = all_1.sq;
i__15[7] = 9, a__11[7] = "zalaligne";
i__15[8] = 1, a__11[8] = all_1.sq;
i__15[9] = 3, a__11[9] = "let";
i__15[10] = 1, a__11[10] = all_1.sq;
i__15[11] = 8, a__11[11] = "barnoadd";
i__15[12] = 1, a__11[12] = all_1.sq;
i__15[13] = 4, a__11[13] = "bnat";
s_cat(ch__32, a__11, i__15, &c__14, (
ftnlen)69);
do_fio(&c__1, ch__32, (ftnlen)69);
e_wsfe();
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
s_wsfe(&io___1400);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 10, a__2[1] = "addspace{-";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 14, a__2[3] = "afterruleskip}";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 14, a__2[5] = "zchangecontext";
s_cat(ch__33, a__2, i__4, &c__6, (ftnlen)
41);
do_fio(&c__1, ch__33, (ftnlen)41);
e_wsfe();
}
if (all_1.ibar == comgrace_1.ibarmbr) {
comgrace_1.xb4mbr = comstart_1.facmtr *
all_1.musicsize;
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1401);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "alaligne";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)
9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1402);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "alaligne";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
}
}
}
/* Modified 090525 to use \bnrs */
if (slint) {
slint = FALSE_;
if (comlast_1.islast) {
s_wsfe(&io___1403);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 3, a__3[1] = "def";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 11, a__3[3] = "raisebarno{";
s_cat(ch__21, a__3, i__5, &c__4, (ftnlen)16);
do_fio(&c__1, ch__21, (ftnlen)16);
do_fio(&c__1, (char *)&comsln_1.irzbnd, (ftnlen)
sizeof(integer));
/* Writing concatenation */
i__8[0] = 2, a__5[0] = ".5";
i__8[1] = 1, a__5[1] = all_1.sq;
i__8[2] = 11, a__5[2] = "internote}%";
s_cat(ch__10, a__5, i__8, &c__3, (ftnlen)14);
do_fio(&c__1, ch__10, (ftnlen)14);
e_wsfe();
}
}
comget_1.movbrk = 0;
}
/* Clean up if we squelched bar number reset at movement break */
if (comnotes_1.nobar1) {
if (comlast_1.islast) {
s_wsfe(&io___1404);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "startbarno1";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
comnotes_1.nobar1 = FALSE_;
}
i__7 = s_rsle(&io___1405);
if (i__7 != 0) {
goto L14;
}
i__7 = do_lio(&c__3, &c__1, (char *)&iauto, (ftnlen)sizeof(
integer));
if (i__7 != 0) {
goto L14;
}
i__7 = e_rsle();
if (i__7 != 0) {
goto L14;
}
L14:
/* We come thru here for the 1st bar of every system, so initialize is1n1 */
comsln_1.is1n1 = 0;
/* Brought down from above */
if (isystpg == comnotes_1.nsystp[comnotes_1.ipage - 1]) {
isystpg = 0;
}
/* Check for linebreak ties */
if (ispstie) {
linebreakties_(all_1.isdat1, all_1.isdat2, all_1.isdat3,
all_1.isdat4, &all_1.nsdat, &ispstie, all_1.sepsymq, (
ftnlen)1);
}
} else {
/* Not first bar of system */
if (bit_test(iplnow,28)) {
/* Signature change */
if (all_1.mtrnuml != 0) {
/* Meter+signature change mid line, assume no movement break */
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &
combeam_1.ibmtyp, &ibmrep);
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 17, a__4[1] = "generalsignature{";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 18;
if (comtop_1.isig < 0) {
/* Writing concatenation */
i__6[0] = 18, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "-";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 19;
}
if (comlast_1.islast) {
iptemp = abs(comtop_1.isig) + 48;
chax_(ch__1, (ftnlen)1, &iptemp);
*(unsigned char *)charq = *(unsigned char *)&ch__1[0];
/* Writing concatenation */
i__8[0] = lnote, a__5[0] = notexq;
i__8[1] = 1, a__5[1] = charq;
i__8[2] = 2, a__5[2] = "}%";
s_cat(notexq, a__5, i__8, &c__3, (ftnlen)79);
lnote += 3;
s_wsfe(&io___1408);
do_fio(&c__1, notexq, lnote);
e_wsfe();
if (comlast_1.islast && cominsttrans_1.laterinsttrans)
{
writesetsign_(&cominsttrans_1.ninsttrans,
cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &
cominsttrans_1.laterinsttrans);
}
if (comignorenats_1.ignorenats) {
s_wsfe(&io___1409);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
s_wsfe(&io___1410);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 15, a__4[1] = "xchangecontext%";
s_cat(ch__21, a__4, i__6, &c__2, (ftnlen)16);
do_fio(&c__1, ch__21, (ftnlen)16);
e_wsfe();
}
if (all_1.ibar == comgrace_1.ibarmbr) {
/* Compute space for multibar rest */
if (comtop_1.lastisig * comtop_1.isig >= 0) {
/* Computing MAX */
i__7 = abs(comtop_1.lastisig), i__2 = abs(
comtop_1.isig);
naccs = max(i__7,i__2);
} else {
naccs = (i__7 = comtop_1.lastisig - comtop_1.isig,
abs(i__7));
}
comgrace_1.xb4mbr = (comstart_1.facmtr + naccs * .24f)
* all_1.musicsize;
}
} else {
/* Signature change only */
/* Writing concatenation */
i__14[0] = 1, a__10[0] = all_1.sq;
i__14[1] = 4, a__10[1] = "xbar";
i__14[2] = 1, a__10[2] = all_1.sq;
i__14[3] = 10, a__10[3] = "addspace{-";
i__14[4] = 1, a__10[4] = all_1.sq;
i__14[5] = 14, a__10[5] = "afterruleskip}";
i__14[6] = 1, a__10[6] = all_1.sq;
i__14[7] = 17, a__10[7] = "generalsignature{";
s_cat(notexq, a__10, i__14, &c__8, (ftnlen)79);
lnote = 49;
if (comtop_1.isig < 0) {
/* Writing concatenation */
i__6[0] = 49, a__4[0] = notexq;
i__6[1] = 1, a__4[1] = "-";
s_cat(notexq, a__4, i__6, &c__2, (ftnlen)79);
lnote = 50;
}
if (comlast_1.islast) {
s_wsfe(&io___1412);
/* Writing concatenation */
i__8[0] = lnote, a__5[0] = notexq;
i__7 = abs(comtop_1.isig) + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__8[1] = 1, a__5[1] = ch__1;
i__8[2] = 2, a__5[2] = "}%";
s_cat(ch__24, a__5, i__8, &c__3, (ftnlen)82);
do_fio(&c__1, ch__24, lnote + 3);
e_wsfe();
}
if (comlast_1.islast && cominsttrans_1.laterinsttrans) {
writesetsign_(&cominsttrans_1.ninsttrans,
cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &
cominsttrans_1.laterinsttrans);
}
if (comlast_1.islast && comignorenats_1.ignorenats) {
s_wsfe(&io___1413);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "ignorenats%";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1414);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 14, a__2[1] = "zchangecontext";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 12, a__2[3] = "addspace{-.5";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 15, a__2[5] = "afterruleskip}%";
s_cat(ch__34, a__2, i__4, &c__6, (ftnlen)44);
do_fio(&c__1, ch__34, (ftnlen)44);
e_wsfe();
}
if (all_1.ibar == comgrace_1.ibarmbr) {
/* Compute space for multibar rest */
if (comtop_1.lastisig * comtop_1.isig >= 0) {
/* Computing MAX */
i__7 = abs(comtop_1.lastisig), i__2 = abs(
comtop_1.isig);
naccs = max(i__7,i__2);
} else {
naccs = (i__7 = comtop_1.lastisig - comtop_1.isig,
abs(i__7));
}
comgrace_1.xb4mbr = naccs * .24f * all_1.musicsize;
}
}
} else if (all_1.mtrnuml == 0) {
/* No meter change */
if (comlast_1.islast) {
s_wsfe(&io___1415);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 4, a__4[1] = "xbar";
s_cat(ch__35, a__4, i__6, &c__2, (ftnlen)5);
do_fio(&c__1, ch__35, (ftnlen)5);
e_wsfe();
}
} else {
/* Change meter midline */
setmeter_(&all_1.mtrnuml, &all_1.mtrdenl, &combeam_1.ibmtyp, &
ibmrep);
if (comget_1.movbrk == 0) {
if (comlast_1.islast) {
wgmeter_(&all_1.mtrnmp, &all_1.mtrdnp);
}
if (all_1.mtrdnp > 0) {
if (comlast_1.islast) {
s_wsfe(&io___1416);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "newtimes0%";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
e_wsfe();
}
if (all_1.ibar == comgrace_1.ibarmbr) {
comgrace_1.xb4mbr = comstart_1.facmtr *
all_1.musicsize;
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1417);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 4, a__4[1] = "xbar";
s_cat(ch__35, a__4, i__6, &c__2, (ftnlen)5);
do_fio(&c__1, ch__35, (ftnlen)5);
e_wsfe();
}
}
}
}
}
/* Now that xbar's are written, can put in left-repeats at line beginnings */
if (lrptpend) {
if (comlast_1.islast) {
s_wsfe(&io___1418);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 7, a__2[1] = "advance";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 7, a__2[3] = "barno-1";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 10, a__2[5] = "leftrepeat";
s_cat(ch__5, a__2, i__4, &c__6, (ftnlen)27);
do_fio(&c__1, ch__5, (ftnlen)27);
e_wsfe();
}
lrptpend = FALSE_;
}
if (all_1.ibar > 1) {
/* For bars after first, slide all stuff down to beginning of arrays */
i__7 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__7; ++all_1.iv) {
i__2 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__2; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
ioff = all_1.nib[commvl_1.ivx + (all_1.ibar - 1) * 24 -
25];
i__13 = all_1.nib[commvl_1.ivx + all_1.ibar * 24 - 25] -
ioff;
for (ip = 1; ip <= i__13; ++ip) {
all_1.nolev[commvl_1.ivx + ip * 24 - 25] =
all_1.nolev[commvl_1.ivx + (ip + ioff) * 24 -
25];
all_1.nodur[commvl_1.ivx + ip * 24 - 25] =
all_1.nodur[commvl_1.ivx + (ip + ioff) * 24 -
25];
all_1.nacc[commvl_1.ivx + ip * 24 - 25] = all_1.nacc[
commvl_1.ivx + (ip + ioff) * 24 - 25];
all_1.irest[commvl_1.ivx + ip * 24 - 25] =
all_1.irest[commvl_1.ivx + (ip + ioff) * 24 -
25];
all_1.islur[commvl_1.ivx + ip * 24 - 25] =
all_1.islur[commvl_1.ivx + (ip + ioff) * 24 -
25];
all_1.ipl[commvl_1.ivx + ip * 24 - 25] = all_1.ipl[
commvl_1.ivx + (ip + ioff) * 24 - 25];
all_1.iornq[commvl_1.ivx + ip * 24 - 1] = all_1.iornq[
commvl_1.ivx + (ip + ioff) * 24 - 1];
all_1.mult[commvl_1.ivx + ip * 24 - 25] = all_1.mult[
commvl_1.ivx + (ip + ioff) * 24 - 25];
/* if (ivx.le.2 .and. figbass) */
/* * isfig(ivx,ip) = isfig(ivx,ip+ioff) */
if (all_1.figbass && commvl_1.ivx == 1 ||
commvl_1.ivx == comfig_1.ivxfig2) {
if (commvl_1.ivx == 1) {
all_1.isfig[(ip << 1) - 2] = all_1.isfig[(ip
+ ioff << 1) - 2];
} else {
all_1.isfig[(ip << 1) - 1] = all_1.isfig[(ip
+ ioff << 1) - 1];
}
}
/* L12: */
}
if (commvl_1.ivx <= all_1.nv && comcc_1.ncc[all_1.iv - 1]
> 1) {
islide = 0;
i__13 = comcc_1.ncc[all_1.iv - 1];
for (icc = 1; icc <= i__13; ++icc) {
if (comcc_1.tcc[all_1.iv + icc * 24 - 25] <= (
real) all_1.lenbar) {
/* This time will drop <=0 when slid. */
islide = icc - 1;
comcc_1.ncmidcc[all_1.iv - 1] =
comcc_1.ncmidcc[all_1.iv + icc * 24 -
25];
} else {
comcc_1.tcc[all_1.iv + (icc - islide) * 24 -
25] = comcc_1.tcc[all_1.iv + icc * 24
- 25] - all_1.lenbar;
comcc_1.ncmidcc[all_1.iv + (icc - islide) *
24 - 25] = comcc_1.ncmidcc[all_1.iv +
icc * 24 - 25];
}
/* L13: */
}
comcc_1.ncc[all_1.iv - 1] -= islide;
comcc_1.tcc[all_1.iv - 1] = 0.f;
}
/* L11: */
}
}
i__2 = comgrace_1.ngrace;
for (ig = 1; ig <= i__2; ++ig) {
comgrace_1.ipg[ig - 1] -= all_1.nib[comgrace_1.ivg[ig - 1] + (
all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
comgrace_1.ipg[ig - 1] += all_1.nib[comgrace_1.ivg[ig - 1]
+ (all_1.ibar - 2) * 24 - 25];
}
/* L15: */
}
i__2 = comgrace_1.nlit;
for (il = 1; il <= i__2; ++il) {
comgrace_1.iplit[il - 1] -= all_1.nib[comgrace_1.ivlit[il - 1]
+ (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
comgrace_1.iplit[il - 1] += all_1.nib[comgrace_1.ivlit[il
- 1] + (all_1.ibar - 2) * 24 - 25];
}
/* L21: */
}
i__2 = comtrill_1.ntrill;
for (it = 1; it <= i__2; ++it) {
comtrill_1.iptrill[it - 1] -= all_1.nib[comtrill_1.ivtrill[it
- 1] + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
comtrill_1.iptrill[it - 1] += all_1.nib[
comtrill_1.ivtrill[it - 1] + (all_1.ibar - 2) *
24 - 25];
}
/* L22: */
}
i__2 = comtrill_1.ncrd;
for (icrd = 1; icrd <= i__2; ++icrd) {
/* ivx = iand(15,ishft(icrdat(icrd),-8)) */
commvl_1.ivx = (15 & lbit_shift(comtrill_1.icrdat[icrd - 1], (
ftnlen)-8)) + (igetbits_(&comtrill_1.icrdat[icrd - 1],
&c__1, &c__28) << 4);
ipnew = (255 & comtrill_1.icrdat[icrd - 1]) - all_1.nib[
commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
comtrill_1.icrdat[icrd - 1] = -256 & comtrill_1.icrdat[icrd -
1];
comtrill_1.icrdat[icrd - 1] = max(0,ipnew) |
comtrill_1.icrdat[icrd - 1];
/* L27: */
}
i__2 = comtrill_1.nudorn;
for (iudorn = 1; iudorn <= i__2; ++iudorn) {
/* ivx = iand(15,ishft(kudorn(iudorn),-8)) */
commvl_1.ivx = comivxudorn_1.ivxudorn[iudorn - 1];
ipnew = (255 & comtrill_1.kudorn[iudorn - 1]) - all_1.nib[
commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
comtrill_1.kudorn[iudorn - 1] = -256 & comtrill_1.kudorn[
iudorn - 1];
comtrill_1.kudorn[iudorn - 1] = max(0,ipnew) |
comtrill_1.kudorn[iudorn - 1];
/* L29: */
}
i__2 = comdyn_1.ndyn;
for (idyn = 1; idyn <= i__2; ++idyn) {
idynd = comdyn_1.idyndat[idyn - 1];
/* ivx = iand(15,idynd) */
commvl_1.ivx = (15 & idynd) + (igetbits_(&comdyn_1.idynda2[
idyn - 1], &c__1, &c__10) << 4);
ipnew = igetbits_(&idynd, &c__8, &c__4) - all_1.nib[
commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
/* The following construction avoids array bound errors in some compilers */
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
ipnew = i_dim(&ipnew, &c__0);
setbits_(&idynd, &c__8, &c__4, &ipnew);
comdyn_1.idyndat[idyn - 1] = idynd;
/* L42: */
}
i__2 = comdyn_1.ntxtdyn;
for (itxtdyn = 1; itxtdyn <= i__2; ++itxtdyn) {
idynd = comdyn_1.ivxiptxt[itxtdyn - 1];
/* ivx = iand(15,idynd) */
commvl_1.ivx = 31 & idynd;
/* ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) */
ipnew = igetbits_(&idynd, &c__8, &c__5) - all_1.nib[
commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
ipnew = i_dim(&ipnew, &c__0);
/* call setbits(idynd,8,4,ipnew) */
setbits_(&idynd, &c__8, &c__5, &ipnew);
comdyn_1.ivxiptxt[itxtdyn - 1] = idynd;
/* L43: */
}
i__2 = all_1.nsdat;
for (isdat = 1; isdat <= i__2; ++isdat) {
isdata = all_1.isdat1[isdat - 1];
commvl_1.ivx = commvl_1.ivmx[igetbits_(&isdata, &c__5, &c__13)
+ (igetbits_(&isdata, &c__1, &c__12) + 1) * 24 - 25];
ipnew = igetbits_(&isdata, &c__8, &c__3) - all_1.nib[
commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
ipnew = i_dim(&ipnew, &c__0);
setbits_(&isdata, &c__8, &c__3, &ipnew);
all_1.isdat1[isdat - 1] = isdata;
/* L41: */
}
i__2 = comcb_1.nbc;
for (ibc = 1; ibc <= i__2; ++ibc) {
/* ivx = iand(15,ibcdata(ibc)) */
commvl_1.ivx = (15 & comcb_1.ibcdata[ibc - 1]) + (igetbits_(&
comcb_1.ibcdata[ibc - 1], &c__1, &c__28) << 4);
ipnew = igetbits_(&comcb_1.ibcdata[ibc - 1], &c__8, &c__4) -
all_1.nib[commvl_1.ivx + (all_1.ibar - 1) * 24 - 25];
if (all_1.ibar > 2) {
ipnew += all_1.nib[commvl_1.ivx + (all_1.ibar - 2) * 24 -
25];
}
ipnew = i_dim(&ipnew, &c__0);
setbits_(&comcb_1.ibcdata[ibc - 1], &c__8, &c__4, &ipnew);
/* L44: */
}
i__2 = comarpshift_1.numarpshift;
for (iarps = 1; iarps <= i__2; ++iarps) {
comarpshift_1.iparpshift[iarps - 1] -= all_1.nib[
comarpshift_1.ivarpshift[iarps - 1] + (all_1.ibar - 1)
* 24 - 25];
if (all_1.ibar > 2) {
comarpshift_1.iparpshift[iarps - 1] += all_1.nib[
comarpshift_1.ivarpshift[iarps - 1] + (all_1.ibar
- 2) * 24 - 25];
}
/* L45: */
}
/* Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. */
/* If there are figs left, it will reset all times relative to start of */
/* current bar. */
for (commvl_1.ivx = 1; commvl_1.ivx <= 2; ++commvl_1.ivx) {
if (all_1.figbass) {
islide = 0;
i__2 = comfig_1.nfigs[commvl_1.ivx - 1];
for (jfig = 1; jfig <= i__2; ++jfig) {
if (comfig_1.itfig[commvl_1.ivx + (jfig << 1) - 3] <
all_1.lenbar) {
/* This figure was already used */
islide = jfig;
} else {
comfig_1.itfig[commvl_1.ivx + (jfig - islide << 1)
- 3] = comfig_1.itfig[commvl_1.ivx + (
jfig << 1) - 3] - all_1.lenbar;
s_copy(comfig_1.figq + (commvl_1.ivx + (jfig -
islide << 1) - 3) * 10, comfig_1.figq + (
commvl_1.ivx + (jfig << 1) - 3) * 10, (
ftnlen)10, (ftnlen)10);
comgrace_1.itoff[commvl_1.ivx + (jfig - islide <<
1) - 3] = comgrace_1.itoff[commvl_1.ivx +
(jfig << 1) - 3];
comfig_1.ivupfig[commvl_1.ivx + (jfig - islide <<
1) - 3] = comfig_1.ivupfig[commvl_1.ivx +
(jfig << 1) - 3];
}
/* L20: */
}
comfig_1.nfigs[commvl_1.ivx - 1] -= islide;
}
if (comfig_1.nfigs[1] == 0) {
goto L47;
}
/* L46: */
}
L47:
;
}
/* End of sliding down for bars after first in gulp. */
/* The following may not be needed by makeabar, but just in case... */
if (all_1.firstgulp && all_1.lenb0 != 0) {
if (all_1.ibar == 1) {
all_1.lenbar = all_1.lenb0;
} else {
all_1.lenbar = all_1.lenb1;
}
}
/* Equal line spacing stuff */
if (comget_1.equalize && comask_1.bar1syst) {
if (isystpg == 1) {
s_wsfe(&io___1434);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "starteq%";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
} else if (isystpg == comnotes_1.nsystp[comnotes_1.ipage - 1] - 1)
{
s_wsfe(&io___1435);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 6, a__4[1] = "endeq%";
s_cat(ch__36, a__4, i__6, &c__2, (ftnlen)7);
do_fio(&c__1, ch__36, (ftnlen)7);
e_wsfe();
}
}
make1bar_(&ibmrep, &tglp1, tstart, cwrest, squez, istop, numbms,
istart);
make2bar_(&comnotes_1.ninow, &tglp1, tstart, cwrest, squez, istop,
numbms, istart, comclefq_1.clefq, (ftnlen)1);
/* Hardspace before barline? */
hardb4 = 0.f;
i__2 = all_1.nv;
for (all_1.iv = 1; all_1.iv <= i__2; ++all_1.iv) {
i__7 = commvl_1.nvmx[all_1.iv - 1];
for (kv = 1; kv <= i__7; ++kv) {
commvl_1.ivx = commvl_1.ivmx[all_1.iv + kv * 24 - 25];
if (bit_test(all_1.irest[commvl_1.ivx + all_1.nn[commvl_1.ivx
- 1] * 24 - 25],18)) {
++comudsp_1.nudoff[commvl_1.ivx - 1];
/* Computing MAX */
r__1 = hardb4, r__2 = comudsp_1.udoff[commvl_1.ivx +
comudsp_1.nudoff[commvl_1.ivx - 1] * 24 - 25];
hardb4 = dmax(r__1,r__2);
}
/* L35: */
}
}
if (hardb4 > 0.f) {
if (comlast_1.islast) {
s_wsfe(&io___1443);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 10, a__4[1] = "hardspace{";
s_cat(ch__17, a__4, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__17, (ftnlen)11);
do_fio(&c__1, (char *)&hardb4, (ftnlen)sizeof(real));
do_fio(&c__1, "pt}%", (ftnlen)4);
e_wsfe();
}
/* This was causing an incorrect poe in an example, which did not affect main */
/* spacing, but did cause an extra accidental space to be too small */
comask_1.fixednew -= hardb4;
}
/* L10: */
}
all_1.firstgulp = FALSE_;
all_1.lenb0 = 0;
goto L30;
L40:
cl__1.cerr = 0;
cl__1.cunit = 12;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = 13;
cl__1.csta = 0;
f_clos(&cl__1);
inbuff_1.ilbuf = 1;
inbuff_1.ipbuf = 0;
wdpt = comtop_1.widthpt;
if (all_1.iline == 1) {
wdpt = comtop_1.widthpt * (1 - comtop_1.fracindent);
}
poe = (wdpt - fsyst * all_1.musicsize - nbarss * .4f - comask_1.fixednew)
/ (elsktot + comask_1.fbar * nbarss - comask_1.scaldold);
poevec[nsyst] = poe;
if (! comlast_1.islast) {
cl__1.cerr = 0;
cl__1.cunit = 11;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = 16;
cl__1.csta = 0;
f_clos(&cl__1);
if (all_1.figbass) {
cl__1.cerr = 0;
cl__1.cunit = 14;
cl__1.csta = 0;
f_clos(&cl__1);
}
return 0;
}
i__1 = comas2_1.nasksys;
for (ia = 1; ia <= i__1; ++ia) {
++comas3_1.iask;
comas3_1.ask[comas3_1.iask - 1] = comas2_1.wasksys[ia - 1] / poe - (
r__1 = comas2_1.elasksys[ia - 1], dabs(r__1));
if (comas2_1.elasksys[ia - 1] > 0.f) {
comas3_1.ask[comas3_1.iask - 1] = r_dim(&comas3_1.ask[
comas3_1.iask - 1], &c_b762);
}
/* L19: */
}
i__1 = nhssys;
for (ia = 1; ia <= i__1; ++ia) {
++nhstot;
/* Computing MAX */
r__1 = hpts[ia - 1] - hesk[ia - 1] * poe;
comhsp_1.hpttot[nhstot - 1] = dmax(r__1,0.f);
/* L26: */
}
if (comlast_1.islast && onvolt) {
s_wsfe(&io___1444);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 11, a__4[1] = "endvoltabox";
s_cat(ch__13, a__4, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__13, (ftnlen)12);
e_wsfe();
}
if (*(unsigned char *)comget_1.rptfq2 != 'E') {
/* Terminal repeat. Right or double? */
if (*(unsigned char *)comget_1.rptfq2 == 'r') {
if (comlast_1.islast) {
s_wsfe(&io___1445);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 14, a__3[1] = "setrightrepeat";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 8, a__3[3] = "endpiece";
s_cat(ch__37, a__3, i__5, &c__4, (ftnlen)24);
do_fio(&c__1, ch__37, (ftnlen)24);
e_wsfe();
}
} else if (*(unsigned char *)comget_1.rptfq2 == 'd') {
if (comlast_1.islast) {
s_wsfe(&io___1446);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 12, a__3[1] = "setdoublebar";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 8, a__3[3] = "endpiece";
s_cat(ch__38, a__3, i__5, &c__4, (ftnlen)22);
do_fio(&c__1, ch__38, (ftnlen)22);
e_wsfe();
}
} else if (*(unsigned char *)comget_1.rptfq2 == 'b') {
if (comlast_1.islast) {
s_wsfe(&io___1447);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "endpiece";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
} else if (*(unsigned char *)comget_1.rptfq2 == 'z') {
if (comlast_1.islast) {
s_wsfe(&io___1448);
/* Writing concatenation */
i__5[0] = 1, a__3[0] = all_1.sq;
i__5[1] = 12, a__3[1] = "setzalaligne";
i__5[2] = 1, a__3[2] = all_1.sq;
i__5[3] = 8, a__3[3] = "Endpiece";
s_cat(ch__38, a__3, i__5, &c__4, (ftnlen)22);
do_fio(&c__1, ch__38, (ftnlen)22);
e_wsfe();
}
} else {
/* else if (rptfq2 .ne. 'D') then */
s_wsle(&io___1449);
e_wsle();
s_wsle(&io___1450);
do_lio(&c__9, &c__1, "R? , ? not \"d\",\"r\",or\"b\",\"z\"; rptf"
"q2:", (ftnlen)37);
do_lio(&c__9, &c__1, comget_1.rptfq2, (ftnlen)1);
e_wsle();
s_wsle(&io___1451);
do_lio(&c__9, &c__1, "R? , ? not \"d\",\"r\",or\"b\",\"z\"; rptf"
"q2:", (ftnlen)37);
do_lio(&c__9, &c__1, comget_1.rptfq2, (ftnlen)1);
e_wsle();
if (comlast_1.islast) {
s_wsfe(&io___1452);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "Endpiece";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1453);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "Endpiece";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
e_wsfe();
}
}
if (! vshrink) {
xnstbot = xnsttop[comnotes_1.ipage - 1] * etabot / etatop;
if (xnstbot < 9.95f) {
s_copy(fmtq, "(a,f3.1,a)", (ftnlen)24, (ftnlen)10);
} else {
s_copy(fmtq, "(a,f4.1,a)", (ftnlen)24, (ftnlen)10);
}
if (comlast_1.islast) {
s_wsfe(&io___1454);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 5, a__4[1] = "vskip";
s_cat(ch__28, a__4, i__6, &c__2, (ftnlen)6);
do_fio(&c__1, ch__28, (ftnlen)6);
do_fio(&c__1, (char *)&xnstbot, (ftnlen)sizeof(real));
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 10, a__2[1] = "Interligne";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 5, a__2[3] = "eject";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 9, a__2[5] = "endmuflex";
s_cat(ch__5, a__2, i__4, &c__6, (ftnlen)27);
do_fio(&c__1, ch__5, (ftnlen)27);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1455);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 3, a__4[1] = "bye";
s_cat(ch__20, a__4, i__6, &c__2, (ftnlen)4);
do_fio(&c__1, ch__20, (ftnlen)4);
e_wsfe();
}
} else {
if (comlast_1.islast) {
s_wsfe(&io___1456);
/* Writing concatenation */
i__4[0] = 1, a__2[0] = all_1.sq;
i__4[1] = 5, a__2[1] = "vfill";
i__4[2] = 1, a__2[2] = all_1.sq;
i__4[3] = 5, a__2[3] = "eject";
i__4[4] = 1, a__2[4] = all_1.sq;
i__4[5] = 9, a__2[5] = "endmuflex";
s_cat(ch__38, a__2, i__4, &c__6, (ftnlen)22);
do_fio(&c__1, ch__38, (ftnlen)22);
e_wsfe();
}
if (comlast_1.islast) {
s_wsfe(&io___1457);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 3, a__4[1] = "bye";
s_cat(ch__20, a__4, i__6, &c__2, (ftnlen)4);
do_fio(&c__1, ch__20, (ftnlen)4);
e_wsfe();
}
}
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
if (all_1.figbass) {
s_wsfe(&io___1458);
/* Writing concatenation */
i__6[0] = 1, a__4[0] = all_1.sq;
i__6[1] = 8, a__4[1] = "figdrop=";
s_cat(ch__16, a__4, i__6, &c__2, (ftnlen)9);
do_fio(&c__1, ch__16, (ftnlen)9);
do_fio(&c__1, (char *)&all_1.ifigdr[(all_1.iline << 1) - 2], (ftnlen)
sizeof(integer));
/* Writing concatenation */
i__8[0] = 1, a__5[0] = " ";
i__8[1] = 1, a__5[1] = all_1.sq;
i__8[2] = 8, a__5[2] = "figdtwo=";
s_cat(ch__19, a__5, i__8, &c__3, (ftnlen)10);
do_fio(&c__1, ch__19, (ftnlen)10);
do_fio(&c__1, (char *)&all_1.ifigdr[(all_1.iline << 1) - 1], (ftnlen)
sizeof(integer));
/* Writing concatenation */
i__12[0] = 1, a__9[0] = all_1.sq;
i__12[1] = 4, a__9[1] = "fi}%";
s_cat(ch__35, a__9, i__12, &c__2, (ftnlen)5);
do_fio(&c__1, ch__35, (ftnlen)5);
e_wsfe();
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
}
askfig_(pathnameq, &lpath, basenameq, &lbase, &all_1.figbass, &istype0, (
ftnlen)40, (ftnlen)44);
if (! (*optimize)) {
s_wsle(&io___1459);
e_wsle();
s_wsle(&io___1460);
/* Writing concatenation */
i__5[0] = 8, a__3[0] = "Writing ";
i__5[1] = lpath, a__3[1] = pathnameq;
i__5[2] = lbase, a__3[2] = basenameq;
i__5[3] = 4, a__3[3] = ".tex";
s_cat(ch__39, a__3, i__5, &c__4, (ftnlen)96);
do_lio(&c__9, &c__1, ch__39, lpath + 8 + lbase + 4);
e_wsle();
s_wsle(&io___1461);
do_lio(&c__9, &c__1, "Done with second PMX pass.", (ftnlen)26);
e_wsle();
s_wsfe(&io___1462);
/* Writing concatenation */
i__5[0] = 8, a__3[0] = "Writing ";
i__5[1] = lpath, a__3[1] = pathnameq;
i__5[2] = lbase, a__3[2] = basenameq;
i__5[3] = 4, a__3[3] = ".tex";
s_cat(ch__39, a__3, i__5, &c__4, (ftnlen)96);
do_fio(&c__1, ch__39, lpath + 8 + lbase + 4);
e_wsfe();
s_wsfe(&io___1463);
do_fio(&c__1, " Done with second PMX pass. Now run TeX", (ftnlen)40);
e_wsfe();
}
return 0;
} /* pmxb_ */
/* Subroutine */ int poestats_(integer *nsyst, real *poe, real *poebar, real *
devnorm)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real sumx;
static integer isyst;
static real sumxx;
/* Compute avg. & norm. std. dev. of poe. */
/* Parameter adjustments */
--poe;
/* Function Body */
sumx = 0.f;
sumxx = 0.f;
i__1 = *nsyst;
for (isyst = 1; isyst <= i__1; ++isyst) {
sumx += poe[isyst];
/* Computing 2nd power */
r__1 = poe[isyst];
sumxx += r__1 * r__1;
/* L1: */
}
/* L2: */
/* Computing 2nd power */
r__1 = sumx;
*devnorm = sqrt(*nsyst * sumxx / (r__1 * r__1) - 1);
*poebar = sumx / *nsyst;
return 0;
} /* poestats_ */
/* Subroutine */ int precrd_(integer *ivx, integer *ip, integer *nolevm,
integer *nacc, integer *ipl, integer *irest, char *udq, logical *
twooftwo, integer *icashft, ftnlen udq_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer lbit_shift(integer, integer), s_wsle(cilist *), e_wsle(void),
do_lio(integer *, integer *, char *, ftnlen);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static integer i__, levminacc, levmaxacc, ip1, ile, ivx1, iold, ilev;
static logical is2nd;
extern /* Subroutine */ int stop1_(void);
static integer kicrd[10], nolev, iaccid, naccid, iorder, icrdot0;
extern /* Subroutine */ int crdaccs_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
logical *, integer *);
static integer levtabl[88];
extern /* Subroutine */ int setbits_(integer *, integer *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1471 = { 0, 6, 0, 0, 0 };
static cilist io___1472 = { 0, 6, 0, 0, 0 };
static cilist io___1483 = { 0, 6, 0, 0, 0 };
static cilist io___1484 = { 0, 6, 0, 0, 0 };
/* Analyzes chords, data to be used with slurs on chords and plain chords. */
/* Check for 2nds, shift notes if neccesary. */
/* ipl(10) chord present */
/* irest(20) set if any note is right shifted */
/* irest(27) set if any note is left shifted */
/* ipl(8|9) left|right shift main note */
/* icrdat(23|24) ditto chord note */
/* udq is updown-ness, needed to analyze 2nds. */
/* levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. */
/* icrdot(icrd)(27-29) sequence order of chord note if accid, top down */
for (i__ = 1; i__ <= 88; ++i__) {
levtabl[i__ - 1] = 0;
/* L11: */
}
i__1 = comtrill_1.ncrd;
for (comtrill_1.icrd1 = 1; comtrill_1.icrd1 <= i__1; ++comtrill_1.icrd1) {
ivx1 = (15 & lbit_shift(comtrill_1.icrdat[comtrill_1.icrd1 - 1], (
ftnlen)-8)) + (igetbits_(&comtrill_1.icrdat[comtrill_1.icrd1
- 1], &c__1, &c__28) << 4);
ip1 = 255 & comtrill_1.icrdat[comtrill_1.icrd1 - 1];
if (ip1 == *ip && ivx1 == *ivx) {
goto L2;
}
/* L1: */
}
s_wsle(&io___1471);
e_wsle();
s_wsle(&io___1472);
do_lio(&c__9, &c__1, "Cannot find first chord note in precrd. Send sourc"
"e to Dr. Don!", (ftnlen)63);
e_wsle();
stop1_();
L2:
comtrill_1.maxlev = *nolevm;
comtrill_1.minlev = *nolevm;
levtabl[*nolevm - 1] = -1;
is2nd = FALSE_;
naccid = 0;
levmaxacc = -100;
levminacc = 1000;
/* Check 1st 3 bits of nacc for accid on main note of chord. */
if ((7 & *nacc) > 0) {
naccid = 1;
/* Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, */
/* otherwise icrd value for note with accidental. */
kicrd[0] = 0;
levmaxacc = *nolevm;
levminacc = *nolevm;
/* Start the level-ranking */
icrdot0 = 1;
}
i__1 = comtrill_1.ncrd;
for (comtrill_1.icrd2 = comtrill_1.icrd1; comtrill_1.icrd2 <= i__1;
++comtrill_1.icrd2) {
nolev = igetbits_(&comtrill_1.icrdat[comtrill_1.icrd2 - 1], &c__7, &
c__12);
levtabl[nolev - 1] = comtrill_1.icrd2;
comtrill_1.maxlev = max(comtrill_1.maxlev,nolev);
comtrill_1.minlev = min(comtrill_1.minlev,nolev);
/* Check for accidental */
if (bit_test(comtrill_1.icrdat[comtrill_1.icrd2 - 1],19)) {
++naccid;
levmaxacc = max(levmaxacc,nolev);
levminacc = min(levminacc,nolev);
/* Add this icrd to list of values for notes with accid's. */
kicrd[naccid - 1] = comtrill_1.icrd2;
if (! bit_test(*nacc,28)) {
/* Order not forced, so get the level-ranking, top down */
iorder = 1;
i__2 = naccid - 1;
for (iaccid = 1; iaccid <= i__2; ++iaccid) {
if (kicrd[iaccid - 1] == 0) {
if (*nolevm > nolev) {
++iorder;
} else {
++icrdot0;
}
} else {
if (igetbits_(&comtrill_1.icrdat[kicrd[iaccid - 1] -
1], &c__7, &c__12) > nolev) {
++iorder;
} else {
iold = igetbits_(&comtrill_1.icrdot[kicrd[iaccid
- 1] - 1], &c__3, &c__27);
i__3 = iold + 1;
setbits_(&comtrill_1.icrdot[kicrd[iaccid - 1] - 1]
, &c__3, &c__27, &i__3);
}
}
/* L12: */
}
setbits_(&comtrill_1.icrdot[comtrill_1.icrd2 - 1], &c__3, &
c__27, &iorder);
}
}
/* Exit loop if last note in this chord */
if (comtrill_1.icrd2 == comtrill_1.ncrd) {
goto L4;
}
if (igetbits_(&comtrill_1.icrdat[comtrill_1.icrd2], &c__8, &c__0) != *
ip || igetbits_(&comtrill_1.icrdat[comtrill_1.icrd2], &c__4, &
c__8) + (igetbits_(&comtrill_1.icrdat[comtrill_1.icrd2], &
c__1, &c__28) << 4) != *ivx) {
goto L4;
}
/* * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 */
/* L3: */
}
s_wsle(&io___1483);
e_wsle();
s_wsle(&io___1484);
do_lio(&c__9, &c__1, "Failed to find last chord note. Send source to Dr."
" Don!", (ftnlen)55);
e_wsle();
stop1_();
L4:
/* Now icrd1, icrd2 define range of icrd for this chord. */
/* Bypass autos-shifting if any manual shifts are present */
if (bit_test(*irest,20) || bit_test(*irest,27)) {
goto L10;
}
/* Check for 2nds */
for (ilev = 1; ilev <= 87; ++ilev) {
if (levtabl[ilev - 1] != 0 && levtabl[ilev] != 0) {
/* There is at least one 2nd.. */
if (*(unsigned char *)udq == 'u') {
/* Upstem. Start with 2nd just found and go up, rt-shifting upper */
/* member of each pair */
ile = ilev;
/* Set main-note flag for ANY right-shift */
*irest = bit_set(*irest,20);
L7:
if (levtabl[ile] < 0) {
/* Upstem, & upper member is main so must be rt-shifted. This would move */
/* stem too, so we rt-shift the OTHER note, and set flag that signals */
/* to interchange pitches just when these two notes are placed. */
*nacc = bit_set(*nacc,30);
comtrill_1.icrdat[levtabl[ile - 1] - 1] = bit_set(
comtrill_1.icrdat[levtabl[ile - 1] - 1],24);
} else {
/* Upper member is chord note, must be rt-shifted */
comtrill_1.icrdat[levtabl[ile] - 1] = bit_set(
comtrill_1.icrdat[levtabl[ile] - 1],24);
}
++ile;
L8:
++ile;
if (ile < 87) {
if (levtabl[ile - 1] != 0 && levtabl[ile] != 0) {
goto L7;
} else {
goto L8;
}
}
goto L10;
} else {
/* Downstem. Start at top and work down, left-shifting lower member of each pair. */
/* We know that lowest pair is at (ilev,ilev+1). */
ile = 88;
/* Set main-note flag for ANY right-shift */
*irest = bit_set(*irest,27);
L9:
if (levtabl[ile - 1] != 0 && levtabl[ile - 2] != 0) {
if (levtabl[ile - 2] < 0) {
/* ipl = ibset(ipl,8) */
/* Dnstem, & lower member is main so must be left-shifted. This would move */
/* stem too, so we left-shift the OTHER note, and set flag that signals */
/* to interchange pitches just when these two notes are placed. */
*nacc = bit_set(*nacc,31);
comtrill_1.icrdat[levtabl[ile - 1] - 1] = bit_set(
comtrill_1.icrdat[levtabl[ile - 1] - 1],23);
} else {
/* Lower member is chord note, must be shifted */
comtrill_1.icrdat[levtabl[ile - 2] - 1] = bit_set(
comtrill_1.icrdat[levtabl[ile - 2] - 1],23);
}
--ile;
}
--ile;
if (ile >= ilev + 1) {
goto L9;
}
goto L10;
}
}
/* L5: */
}
L10:
/* Done with 2nds, now do accid's. Call even if just one, in case left shifts. */
/* if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, */
if (naccid >= 1) {
crdaccs_(nacc, ipl, irest, &naccid, kicrd, nolevm, &levmaxacc, &
levminacc, &icrdot0, twooftwo, icashft);
}
return 0;
} /* precrd_ */
/* Subroutine */ int printl_(char *string, ftnlen string_len)
{
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___1487 = { 0, 6, 0, 0, 0 };
static cilist io___1488 = { 0, 15, 0, "(a)", 0 };
/* Send string to console and to log file */
s_wsle(&io___1487);
do_lio(&c__9, &c__1, string, string_len);
e_wsle();
s_wsfe(&io___1488);
do_fio(&c__1, string, string_len);
e_wsfe();
return 0;
} /* printl_ */
/* Subroutine */ int putarp_(real *tnow, integer *iv, integer *ip, integer *
nolev, integer *ncm, char *soutq, integer *lsout, ftnlen soutq_len)
{
/* Initialized data */
static char symq[8*2] = "raisearp" "arpeggio";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2[2], i__3[3], i__4[4];
real r__1;
char ch__1[1], ch__2[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, i_nint(real *);
/* Local variables */
static logical isarpshift;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer iarp, isym, iarps, lnote;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static integer levbot, ilvert, invert;
static char notexq[79];
/* Fortran I/O blocks */
static icilist io___1494 = { 0, notexq+9, 0, "(f3.1,a2)", 5, 1 };
/* Find which iarp, if any */
i__1 = comarp_1.narp;
for (iarp = 1; iarp <= i__1; ++iarp) {
if ((r__1 = *tnow - comarp_1.tar[iarp - 1], dabs(r__1)) <
comtol_1.tol) {
goto L2;
}
/* L1: */
}
/* If here, this is the *first* call for this arp. */
++comarp_1.narp;
comarp_1.tar[comarp_1.narp - 1] = *tnow + comtol_1.tol * .5f;
comarp_1.ivar1[comarp_1.narp - 1] = *iv;
comarp_1.ipar1[comarp_1.narp - 1] = *ip;
comarp_1.levar1[comarp_1.narp - 1] = *nolev;
comarp_1.ncmar1[comarp_1.narp - 1] = *ncm;
return 0;
L2:
/* If here, this is *second* call at this time, iarp points to values from 1st. */
/* Check for shift. Set IsArpShift and iarps */
i__1 = comarpshift_1.numarpshift;
for (iarps = 1; iarps <= i__1; ++iarps) {
if (comarpshift_1.ivarpshift[iarps - 1] == comarp_1.ivar1[iarp - 1] &&
comarpshift_1.iparpshift[iarps - 1] == comarp_1.ipar1[iarp -
1]) {
isarpshift = TRUE_;
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 8, a__1[1] = "loffset{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
s_wsfi(&io___1494);
do_fio(&c__1, (char *)&comarpshift_1.arpshift[iarps - 1], (ftnlen)
sizeof(real));
do_fio(&c__1, "}{", (ftnlen)2);
e_wsfi();
lnote = 14;
goto L4;
}
/* L3: */
}
isarpshift = FALSE_;
lnote = 0;
L4:
if (*iv == comarp_1.ivar1[iarp - 1]) {
/* Arp is in a single staff. */
/* Computing MIN */
i__1 = comarp_1.levar1[iarp - 1];
levbot = min(i__1,*nolev) - *ncm + 3;
invert = (i__1 = comarp_1.levar1[iarp - 1] - *nolev, abs(i__1)) + 1;
} else {
/* Arp covers >1 staff. Lower staff has to be the first, upper is current and */
/* is where the symbol will be written. */
r__1 = comarp_1.xinsnow * 2;
levbot = -i_nint(&r__1) + 3 + comarp_1.levar1[iarp - 1] -
comarp_1.ncmar1[iarp - 1];
invert = -levbot + 4 + *nolev - *ncm;
/* print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' */
/* write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), */
/* *levbot,nolev,ncm */
}
/* isym will be (1,2) if invert is (even,odd). If even, raise .5\internote */
isym = invert % 2 + 1;
ilvert = (invert + 1) / 2;
if (levbot >= 0 && levbot <= 9) {
/* Single digit */
if (! isarpshift) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__2[0] = ch__1;
i__3[1] = 8, a__2[1] = symq + (isym - 1 << 3);
i__1 = levbot + 48;
chax_(ch__2, (ftnlen)1, &i__1);
i__3[2] = 1, a__2[2] = ch__2;
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 8, a__3[2] = symq + (isym - 1 << 3);
i__1 = levbot + 48;
chax_(ch__2, (ftnlen)1, &i__1);
i__4[3] = 1, a__3[3] = ch__2;
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
}
lnote += 10;
} else {
if (! isarpshift) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__2[0] = ch__1;
i__3[1] = 8, a__2[1] = symq + (isym - 1 << 3);
i__3[2] = 1, a__2[2] = "{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79);
} else {
/* Writing concatenation */
i__4[0] = lnote, a__3[0] = notexq;
chax_(ch__1, (ftnlen)1, &c__92);
i__4[1] = 1, a__3[1] = ch__1;
i__4[2] = 8, a__3[2] = symq + (isym - 1 << 3);
i__4[3] = 1, a__3[3] = "{";
s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79);
}
lnote += 10;
if (levbot >= -9) {
/* Need two spaces for number */
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&levbot, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
lnote += 3;
} else {
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i3,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&levbot, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
lnote += 4;
}
}
/* if (ilvert .le. 9) then */
/* call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, */
/* * soutq,lsout) */
/* else */
/* write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' */
/* call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) */
/* end if */
if (ilvert > 9) {
i__1 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(a1,i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
do_fio(&c__1, (char *)&ilvert, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
lnote += 4;
} else {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__1 = ilvert + 48;
chax_(ch__1, (ftnlen)1, &i__1);
i__2[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++lnote;
}
if (isarpshift) {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++lnote;
}
addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80);
/* cancel out the stored time, to permit two arps at same time! */
comarp_1.tar[iarp - 1] = -1.f;
return 0;
} /* putarp_ */
/* Subroutine */ int putast_(real *elask, integer *indxask, char *outq,
ftnlen outq_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2[3];
icilist ici__1;
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
/* Local variables */
static integer lp;
static char tag[129], fmtq[9];
/* Fortran I/O blocks */
static icilist io___1502 = { 0, fmtq, 0, "(a5,i1,a3)", 9, 1 };
if (*elask >= 0.f) {
if (*elask < .995f) {
lp = 3;
} else if (*elask < 9.995f) {
lp = 4;
} else {
lp = 5;
}
s_wsfi(&io___1502);
do_fio(&c__1, "(a2,f", (ftnlen)5);
do_fio(&c__1, (char *)&lp, (ftnlen)sizeof(integer));
do_fio(&c__1, ".2)", (ftnlen)3);
e_wsfi();
} else {
lp = 5;
s_copy(fmtq, "(a2,f5.1)", (ftnlen)9, (ftnlen)9);
}
/* Overwrite as follows: ...xyz*ask *lmnop... -> */
/* ...xyz*ast{.nn}*lmnop... */
/* ...xyz*ast{n.nn}*lmnop... */
/* ...xyz*ast{nn.nn}*lmnop... */
/* or for negative, ...xyz*ast{-nn.n}*lmnop... */
i__1 = *indxask + 8;
s_copy(tag, outq + i__1, (ftnlen)129, 129 - i__1);
i__1 = *indxask + 2;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 129 - i__1;
ici__1.iciunit = outq + i__1;
ici__1.icifmt = fmtq;
s_wsfi(&ici__1);
do_fio(&c__1, "t{", (ftnlen)2);
do_fio(&c__1, (char *)&(*elask), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__2[0] = *indxask + 4 + lp, a__1[0] = outq;
i__2[1] = 1, a__1[1] = "}";
i__2[2] = 129, a__1[2] = tag;
s_cat(outq, a__1, i__2, &c__3, (ftnlen)129);
return 0;
} /* putast_ */
/* Subroutine */ int putcb_(integer *ivx, integer *ip, char *notexq, integer *
lnote, ftnlen notexq_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__1[1];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen), s_copy(char *, char *,
ftnlen, ftnlen), s_cat(char *, char **, integer *, integer *,
ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static integer ibc, ipbc, ivxbc;
static real hshft;
static integer ihshft, ivshft;
extern /* Subroutine */ int printl_(char *, ftnlen);
/* ivxip = ivx+16*ip */
i__1 = comcb_1.nbc;
for (ibc = 1; ibc <= i__1; ++ibc) {
/* if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 */
/* if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) */
/* * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 */
ivxbc = (15 & comcb_1.ibcdata[ibc - 1]) + (igetbits_(&comcb_1.ibcdata[
ibc - 1], &c__1, &c__28) << 4);
ipbc = igetbits_(&comcb_1.ibcdata[ibc - 1], &c__8, &c__4);
if (*ivx == ivxbc && *ip == ipbc) {
goto L2;
}
/* L1: */
}
printl_("Error in putbc, Call Dr. Don", (ftnlen)28);
s_stop("", (ftnlen)0);
L2:
if (bit_test(comcb_1.ibcdata[ibc - 1],27)) {
*lnote = 8;
s_copy(notexq, "\\pbreath", (ftnlen)79, (ftnlen)8);
} else {
*lnote = 9;
s_copy(notexq, "\\pcaesura", (ftnlen)79, (ftnlen)9);
}
ivshft = igetbits_(&comcb_1.ibcdata[ibc - 1], &c__6, &c__13);
/* ?? ivshft = igetbits(ibcdata(ibc),6,13)-32 */
if (ivshft > 0) {
ivshft += -32;
}
if (ivshft < 0 || ivshft > 9) {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "{";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
if (ivshft < -9) {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i3)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&ivshft, (ftnlen)sizeof(integer));
e_wsfi();
*lnote += 3;
} else {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 2 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(i2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&ivshft, (ftnlen)sizeof(integer));
e_wsfi();
*lnote += 2;
}
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
} else {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
*(unsigned char *)&ch__1[0] = ivshft + 48;
i__2[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
}
ihshft = igetbits_(&comcb_1.ibcdata[ibc - 1], &c__8, &c__19);
if (ihshft == 0) {
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "0";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
} else {
hshft = (ihshft - 128) * .1f;
/* -12.8 9.95f) {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f4.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real));
e_wsfi();
*lnote += 4;
} else {
i__1 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f3.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real));
e_wsfi();
*lnote += 3;
}
/* Writing concatenation */
i__2[0] = *lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++(*lnote);
}
return 0;
} /* putcb_ */
/* Subroutine */ int putfig_(integer *ivx, integer *ifig, real *offnsk,
logical *figcheck, char *soutq, integer *lsout, ftnlen soutq_len)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[6], a__4[4];
integer i__1[2], i__2[3], i__3, i__4[6], i__5[4];
real r__1;
char ch__1[1], ch__2[22], ch__3[21], ch__4[20], ch__5[19], ch__6[18],
ch__7[13], ch__8[11], ch__9[8], ch__10[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ic;
static char sq[1];
static integer nof;
static char ch1q[1], ch2q[1];
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer nofa;
static char figq[10];
static integer lnof;
static char nofq[5];
static integer lnum, lnofa;
static char nofaq[5];
static integer icnum, lnote;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char figutq[4], conttq[4], notexq[80];
extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
;
/* Fortran I/O blocks */
static icilist io___1514 = { 0, notexq+5, 0, "(f6.2)", 6, 1 };
static icilist io___1516 = { 0, notexq+5, 0, "(f5.2)", 5, 1 };
static icilist io___1517 = { 0, notexq+5, 0, "(f4.2)", 4, 1 };
static icilist io___1518 = { 0, notexq+5, 0, "(f3.2)", 3, 1 };
static icilist io___1531 = { 0, notexq+5, 0, "(f6.2)", 6, 1 };
static icilist io___1532 = { 0, notexq+5, 0, "(f5.2)", 5, 1 };
static icilist io___1533 = { 0, notexq+5, 0, "(f4.2)", 4, 1 };
static icilist io___1534 = { 0, notexq+5, 0, "(f3.2)", 3, 1 };
if (*ivx == 1) {
s_copy(figutq, "Figu", (ftnlen)4, (ftnlen)4);
s_copy(conttq, "Cont", (ftnlen)4, (ftnlen)4);
} else {
s_copy(figutq, "Figt", (ftnlen)4, (ftnlen)4);
s_copy(conttq, "Cott", (ftnlen)4, (ftnlen)4);
}
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
if (dabs(*offnsk) > 1e-4f) {
/* Write offset for floating figure, to two decimal places */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 4, a__1[1] = "off{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)80);
if (-(*offnsk) < -9.995f) {
s_wsfi(&io___1514);
r__1 = -(*offnsk);
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfi();
lnote = 11;
} else if (-(*offnsk) < -.995f || -(*offnsk) > 9.995f) {
s_wsfi(&io___1516);
r__1 = -(*offnsk);
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfi();
lnote = 10;
} else if (-(*offnsk) < -1e-4f || -(*offnsk) > .995f) {
s_wsfi(&io___1517);
r__1 = -(*offnsk);
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfi();
lnote = 9;
} else {
s_wsfi(&io___1518);
r__1 = -(*offnsk);
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfi();
lnote = 8;
}
/* Writing concatenation */
i__2[0] = lnote, a__2[0] = notexq;
i__2[1] = 1, a__2[1] = sq;
i__2[2] = 9, a__2[2] = "noteskip}";
s_cat(notexq, a__2, i__2, &c__3, (ftnlen)80);
i__3 = lnote + 10;
addstr_(notexq, &i__3, soutq, lsout, (ftnlen)80, (ftnlen)80);
}
s_copy(figq, comfig_2.figqq + (*ivx + (*ifig << 1) - 3) * 10, (ftnlen)10,
(ftnlen)10);
ic = 1;
/* nof = 0 */
/* nofa = -1 */
nof = -comfig_2.ivupfig[*ivx + (*ifig << 1) - 3];
nofa = -comfig_2.ivupfig[*ivx + (*ifig << 1) - 3] - 1;
/* Beginning of manual loop */
L1:
*(unsigned char *)ch1q = *(unsigned char *)&figq[ic - 1];
/* Exit when first blank is encountered */
if (*(unsigned char *)ch1q == ' ') {
goto L2;
}
/* Starting a level. Set up vertical offset. */
/* lnof = 1 */
/* nofq = chax(nof+48) */
/* if (nof .gt. 9) then */
/* lnof = 2 */
/* nofq = '1'//chax(nof-10+48) */
/* end if */
/* if (nofa .eq.-1) then */
/* lnofa = 2 */
/* nofaq = '-1' */
/* else if (nofa .lt. 10) then */
/* lnofa = 1 */
/* nofaq = chax(nofa+48) */
/* else */
/* lnofa = 2 */
/* nofaq = '1'//chax(nofa+38) */
/* end if */
istring_(&nof, nofq, &lnof, (ftnlen)5);
istring_(&nofa, nofaq, &lnofa, (ftnlen)5);
if (*(unsigned char *)ch1q == '0') {
/* Continuation figure. Next number is length (in noteskips). The number will */
/* end at the first blank or char that is not digit or decimal point. If */
/* colon, it is a separator and must be skipped */
icnum = ic + 1;
L3:
++ic;
if (i_indx("0123456789.", figq + (ic - 1), (ftnlen)11, (ftnlen)1) > 0)
{
goto L3;
}
lnum = ic - icnum;
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = conttq;
i__4[2] = lnof, a__3[2] = nofq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = ic - 1 - (icnum - 1), a__3[4] = figq + (icnum - 1);
i__4[5] = 1, a__3[5] = "}";
s_cat(ch__2, a__3, i__4, &c__6, (ftnlen)22);
i__3 = ic + 7 - icnum + lnof;
addstr_(ch__2, &i__3, soutq, lsout, lnof + 6 + (ic - 1 - (icnum - 1))
+ 1, (ftnlen)80);
if (*(unsigned char *)&figq[ic - 1] != ':') {
--ic;
}
} else if (*(unsigned char *)ch1q == '#' || *(unsigned char *)ch1q == '-'
|| *(unsigned char *)ch1q == 'n') {
++ic;
*(unsigned char *)ch2q = *(unsigned char *)&figq[ic - 1];
if (*(unsigned char *)ch2q == ' ') {
/* Figure is a stand-alone accidental, so must be centered */
if (*(unsigned char *)ch1q == '#') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 9, a__3[5] = "sharpfig}";
s_cat(ch__3, a__3, i__4, &c__6, (ftnlen)21);
i__3 = lnofa + 16;
addstr_(ch__3, &i__3, soutq, lsout, lnofa + 16, (ftnlen)80);
} else if (*(unsigned char *)ch1q == '-') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 8, a__3[5] = "flatfig}";
s_cat(ch__4, a__3, i__4, &c__6, (ftnlen)20);
i__3 = lnofa + 15;
addstr_(ch__4, &i__3, soutq, lsout, lnofa + 15, (ftnlen)80);
} else if (*(unsigned char *)ch1q == 'n') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 7, a__3[5] = "natfig}";
s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)19);
i__3 = lnofa + 14;
addstr_(ch__5, &i__3, soutq, lsout, lnofa + 14, (ftnlen)80);
}
goto L2;
} else {
/* Figure is an accidental followed by a number */
/* First put the accidental (offset to the left) */
if (*(unsigned char *)ch1q == '#') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 6, a__3[5] = "fsmsh}";
s_cat(ch__6, a__3, i__4, &c__6, (ftnlen)18);
i__3 = lnofa + 13;
addstr_(ch__6, &i__3, soutq, lsout, lnofa + 13, (ftnlen)80);
} else if (*(unsigned char *)ch1q == '-') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 6, a__3[5] = "fsmfl}";
s_cat(ch__6, a__3, i__4, &c__6, (ftnlen)18);
i__3 = lnofa + 13;
addstr_(ch__6, &i__3, soutq, lsout, lnofa + 13, (ftnlen)80);
} else if (*(unsigned char *)ch1q == 'n') {
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnofa, a__3[2] = nofaq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = sq;
i__4[5] = 6, a__3[5] = "fsmna}";
s_cat(ch__6, a__3, i__4, &c__6, (ftnlen)18);
i__3 = lnofa + 13;
addstr_(ch__6, &i__3, soutq, lsout, lnofa + 13, (ftnlen)80);
}
/* Now put the number */
/* Writing concatenation */
i__4[0] = 1, a__3[0] = sq;
i__4[1] = 4, a__3[1] = figutq;
i__4[2] = lnof, a__3[2] = nofq;
i__4[3] = 1, a__3[3] = "{";
i__4[4] = 1, a__3[4] = ch2q;
i__4[5] = 1, a__3[5] = "}";
s_cat(ch__7, a__3, i__4, &c__6, (ftnlen)13);
i__3 = lnof + 8;
addstr_(ch__7, &i__3, soutq, lsout, lnof + 8, (ftnlen)80);
}
} else if (*(unsigned char *)ch1q == '_') {
/* Placeholder only (for lowering a figure). Don't do anything! */
} else {
/* Figure is a single number, maybe with s after */
/* Writing concatenation */
i__5[0] = 1, a__4[0] = sq;
i__5[1] = 4, a__4[1] = figutq;
i__5[2] = lnof, a__4[2] = nofq;
i__5[3] = 1, a__4[3] = "{";
s_cat(ch__8, a__4, i__5, &c__4, (ftnlen)11);
i__3 = lnof + 6;
addstr_(ch__8, &i__3, soutq, lsout, lnof + 6, (ftnlen)80);
i__3 = ic;
s_copy(ch2q, figq + i__3, (ftnlen)1, ic + 1 - i__3);
if (*(unsigned char *)ch2q == 's') {
/* Use a special character. Insert font call */
++ic;
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 7, a__1[1] = "ligfont";
s_cat(ch__9, a__1, i__1, &c__2, (ftnlen)8);
addstr_(ch__9, &c__8, soutq, lsout, (ftnlen)8, (ftnlen)80);
}
/* Writing concatenation */
i__1[0] = 1, a__1[0] = ch1q;
i__1[1] = 1, a__1[1] = "}";
s_cat(ch__10, a__1, i__1, &c__2, (ftnlen)2);
addstr_(ch__10, &c__2, soutq, lsout, (ftnlen)2, (ftnlen)80);
/* call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}', */
/* * 8+lnof,soutq,lsout) */
}
if (ic >= 10) {
goto L2;
}
++ic;
nof += 4;
nofa += 4;
goto L1;
L2:
if (dabs(*offnsk) > 1e-4f) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 4, a__1[1] = "off{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)80);
if (*offnsk < -9.995f) {
s_wsfi(&io___1531);
do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real));
e_wsfi();
lnote = 11;
} else if (*offnsk < -.995f || *offnsk > 9.995f) {
s_wsfi(&io___1532);
do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real));
e_wsfi();
lnote = 10;
} else if (*offnsk < -1e-4f || *offnsk > .995f) {
s_wsfi(&io___1533);
do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real));
e_wsfi();
lnote = 9;
} else {
s_wsfi(&io___1534);
do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real));
e_wsfi();
lnote = 8;
}
/* Writing concatenation */
i__2[0] = lnote, a__2[0] = notexq;
i__2[1] = 1, a__2[1] = sq;
i__2[2] = 9, a__2[2] = "noteskip}";
s_cat(notexq, a__2, i__2, &c__3, (ftnlen)80);
i__3 = lnote + 10;
addstr_(notexq, &i__3, soutq, lsout, (ftnlen)80, (ftnlen)80);
}
if (*ifig < comfig_2.nfigs[*ivx - 1]) {
++(*ifig);
} else {
comfig_2.nfigs[*ivx - 1] = 0;
*figcheck = FALSE_;
}
return 0;
} /* putfig_ */
/* Subroutine */ int putorn_(integer *iornq, integer *nolev, integer *nolevm,
integer *nodur, integer *nornb, char *ulq, integer *ibmcnt, integer *
ivx, integer *ncm, integer *islur, integer *nvmx, integer *nv,
integer *ihornb, real *stemlin, char *outq, integer *lout, integer *
ip, integer *islhgt, logical *beamon, logical *iscrd, ftnlen ulq_len,
ftnlen outq_len)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[6];
integer i__1, i__2, i__3[2], i__4[3], i__5[6];
real r__1, r__2;
char ch__1[1], ch__2[6];
icilist ici__1;
/* Builtin functions */
integer pow_ii(integer *, integer *), i_nint(real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer lbit_shift(integer, integer), i_dim(integer *, integer *), s_wsfi(
icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int addblank_(char *, integer *, ftnlen);
static logical usehornb;
static char sq[1];
extern integer log2_(integer *);
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer ioff, ibit;
extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *,
integer *, integer *, integer *, integer *);
extern integer lfmt1_(real *);
static integer ibitt, ihorn, lform, lnote;
static char noteq[8];
static integer iornt;
static char ulpzq[1];
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten, iudorn;
static char notexq[79];
static integer iclracc, ioffinc;
static real stemlen;
extern /* Subroutine */ int dotrill_(integer *, integer *, integer *,
char *, integer *, char *, integer *, ftnlen, ftnlen);
/* All args are individual array element *values* except nornb,ihornb,ulq. */
/* notcrd = .true. if ornament is on main note. */
/* nolevm is level of main note (for chords) */
/* Parameter adjustments */
ihornb -= 25;
ulq -= 25;
--nornb;
/* Function Body */
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
*lout = 0;
usehornb = FALSE_;
if (*nodur < 64) {
stemlen = *stemlin;
} else {
stemlen = 0.f;
}
/* Get up-downness. ulpzq is opposite from stem direction for both beams and */
/* non beams. Can use in name of ornament [ . or _ ] */
if (*beamon) {
if (*(unsigned char *)&ulq[*ivx + *ibmcnt * 24] == 'u') {
*(unsigned char *)ulpzq = 'l';
} else {
*(unsigned char *)ulpzq = 'u';
}
} else {
udqq_(ch__1, (ftnlen)1, nolevm, ncm, islur, nvmx, ivx, nv);
if (*(unsigned char *)&ch__1[0] == 'l') {
*(unsigned char *)ulpzq = 'u';
} else {
*(unsigned char *)ulpzq = 'l';
}
}
/* To enable >1 ornament on a note, next line is top of manual loop. */
L2:
/* Bit # of last ornament (last of bits 0-21) */
/* c Bit # of last ornament (last of bits 0-24) */
i__1 = *iornq & 4194303;
ibit = log2_(&i__1);
/* ibit = log2(iand(iornq,33554431)) */
iornt = pow_ii(&c__2, &ibit);
/* Begin routine to set height. Bits 0-13: (stmgx+Tupf._) */
/* 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n */
/* 19-20: >^, 21: ? (with or w/o 16-18) */
/* Do not use beam height for . or _ */
if (bit_test(*iornq,22) && (iornt & 6144) == 0) {
/* Height is set by special beam stuff. */
/* Do not leave ihorn set, do separately for every ornament */
ihorn = ihornb[*ivx + nornb[*ivx] * 24];
if (*(unsigned char *)ulpzq == 'u') {
ihorn += -2;
}
/* Following flag tells whether to increment nornb when exiting the subroutine. */
usehornb = TRUE_;
} else if (ibit == 14) {
/* Down fermata. Don't worry about upper chord notes. */
if (*(unsigned char *)ulpzq == 'l') {
/* Computing MIN */
i__1 = *nolev, i__2 = *ncm - 3;
ihorn = min(i__1,i__2);
} else {
/* Computing MIN */
r__1 = *nolev - stemlen, r__2 = *ncm - 3.f;
ihorn = dmin(r__1,r__2);
}
} else if (bit_test(iornt,13) || bit_test(iornt,0)) {
/* ( or ) */
ihorn = *nolev;
} else if ((iornt & 6144) > 0) {
/* c Staccato . or tenuto _ , but not special beam stuff. Need up-down info */
/* NOTE: removed .&_ from special beam treatment. */
/* Staccato . or tenuto _ Need up-down info */
if (! (*iscrd) || comtrill_1.maxlev != *nolev && *(unsigned char *)
ulpzq == 'l' || comtrill_1.minlev != *nolev && *(unsigned
char *)ulpzq == 'u') {
ihorn = *nolev;
} else if (comtrill_1.maxlev == *nolev) {
*(unsigned char *)ulpzq = 'u';
/* Computing MAX */
r__1 = *nolev + stemlen, r__2 = *ncm + 3.f;
ihorn = dmax(r__1,r__2);
} else {
*(unsigned char *)ulpzq = 'l';
/* Computing MIN */
r__1 = *nolev - stemlen, r__2 = *ncm - 3.f;
ihorn = dmin(r__1,r__2);
}
} else if (*iscrd && *nolev == comtrill_1.minlev) {
if (*(unsigned char *)ulpzq == 'l') {
/* Computing MIN */
i__1 = *nolev - 3, i__2 = *ncm - 6;
ihorn = min(i__1,i__2);
} else {
/* Computing MIN */
i__1 = *nolev - i_nint(&stemlen) - 3, i__2 = *ncm - 6;
ihorn = min(i__1,i__2);
}
} else if (ibit == 10 && *nolev > 90) {
/* Special treatment for fermata on a shifted rest */
ihorn = *ncm + 5;
} else if (*(unsigned char *)ulpzq == 'l') {
/* (iscrd and nolev=maxlev) or (.not.iscrd) */
/* Computing MAX */
r__1 = *nolev + stemlen + 2, r__2 = *ncm + 5.f;
ihorn = dmax(r__1,r__2);
} else {
/* Computing MAX */
i__1 = *nolev + 2, i__2 = *ncm + 5;
ihorn = max(i__1,i__2);
}
ioff = 0;
iclracc = 0;
/* Begin routine to set name. Bits 0-13: (stmgx+Tupf._) */
/* 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n */
if (bit_test(iornt,2)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 5, a__1[1] = "shake";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 6;
} else if (bit_test(iornt,3)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 7, a__1[1] = "mordent";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 8;
} else if (bit_test(iornt,1)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "mtr";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,5)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "xtr";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,6)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "ptr";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,13)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "rpn";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,0)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "lpn";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,12)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = sq;
i__4[1] = 1, a__2[1] = ulpzq;
i__4[2] = 2, a__2[2] = "st";
s_cat(notexq, a__2, i__4, &c__3, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,11)) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = sq;
i__4[1] = 1, a__2[1] = ulpzq;
i__4[2] = 2, a__2[2] = "pz";
s_cat(notexq, a__2, i__4, &c__3, (ftnlen)79);
lnote = 4;
} else if (bit_test(iornt,8)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "upz";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
ioff = -2;
} else if (bit_test(iornt,9)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 4, a__1[1] = "uppz";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 5;
ioff = -2;
} else if (bit_test(iornt,10)) {
if (*nodur < 48) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 9, a__1[1] = "fermataup";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 9, a__1[1] = "Fermataup";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
}
lnote = 10;
ioff = -2;
} else if (bit_test(iornt,14)) {
if (*nodur < 48) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 11, a__1[1] = "fermatadown";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 11, a__1[1] = "Fermatadown";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
}
lnote = 12;
} else if (bit_test(iornt,21)) {
/* "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 */
if (bit_test(*iornq,16)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 6, a__1[1] = "qsharp";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 7;
ioff = 2;
*iornq = bit_clear(*iornq,16);
iclracc = 16;
} else if (bit_test(*iornq,17)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 5, a__1[1] = "qflat";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 6;
ioff = 1;
*iornq = bit_clear(*iornq,17);
iclracc = 17;
} else if (bit_test(*iornq,18)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 4, a__1[1] = "qnat";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 5;
ioff = 2;
*iornq = bit_clear(*iornq,18);
iclracc = 18;
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 5, a__1[1] = "qedit";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 6;
ioff = 0;
}
} else if (bit_test(iornt,16)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 6, a__1[1] = "esharp";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 7;
ioff = 2;
} else if (bit_test(iornt,17)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 5, a__1[1] = "eflat";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 6;
ioff = 1;
} else if (bit_test(iornt,18)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 4, a__1[1] = "enat";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 5;
ioff = 2;
} else if (bit_test(iornt,19)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "usf";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 4;
ioff = -2;
} else if (bit_test(iornt,20)) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 4, a__1[1] = "usfz";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote = 5;
ioff = -2;
}
iudorn = 0;
/* User-defined level shift of ornament from default? */
if (bit_test(*iornq,25)) {
/* Find which (if any) element of kudorn has the shift. */
i__1 = comtrill_1.nudorn;
for (iudorn = 1; iudorn <= i__1; ++iudorn) {
if (ibit < 21) {
ibitt = ibit;
/* Could have oes, but not oe? or oes? */
} else if (iclracc > 0) {
/* Earlier cleared edit. accid, meaning it was oes? */
ibitt = iclracc + 6;
} else {
ibitt = 21;
}
ibitt = *ip + (*ivx % 16 << 8) + (*nolev << 12) + (ibitt << 19);
/* if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 */
if (ibitt == (33554431 & comtrill_1.kudorn[iudorn - 1]) && *ivx ==
comivxudorn_1.ivxudorn[iudorn - 1]) {
goto L4;
}
/* L3: */
}
/* Nothing shifted on this note; exit this if block */
iudorn = 0;
goto L5;
L4:
ioffinc = (63 & lbit_shift(comtrill_1.kudorn[iudorn - 1], (ftnlen)-25)
) - 32;
if (ibit == 19 && ioffinc < -7) {
/* Convert usf to lsf. The reason has to do with positioning being impossile */
/* for some mysterious reason when you drop \usf below the staff */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = sq;
i__3[1] = 3, a__1[1] = "lsf";
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
ioffinc += 6;
}
ioff += ioffinc;
}
L5:
/* Shift level to avoid slur. Conditions are */
/* 1. There is a slur */
/* 2. No user-defined orn height shift (btest(iornq,25)) */
/* 3. upslur (islhgt>0) */
/* 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 */
/* 5. islhgt+3 >= height already computed. */
if (! bit_test(*iornq,25) && *islhgt > 0 && (iornt & 30737) == 0) {
i__1 = *islhgt + 3;
ioff += i_dim(&i__1, &ihorn);
}
i__1 = ihorn + ioff;
notefq_(noteq, &lnoten, &i__1, ncm, (ftnlen)8);
if (lnoten == 1) {
addblank_(noteq, &lnoten, (ftnlen)8);
}
if ((iornt & 32896) > 0) {
/* T-trill or trill w/o "tr" */
dotrill_(ivx, ip, &iornt, noteq, &lnoten, notexq, &lnote, (ftnlen)8, (
ftnlen)79);
} else {
/* Writing concatenation */
i__3[0] = lnote, a__1[0] = notexq;
i__3[1] = lnoten, a__1[1] = noteq;
s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79);
lnote += lnoten;
}
if (iudorn > 0) {
if (bit_test(comtrill_1.kudorn[iudorn - 1],31)) {
/* Horizontal shift */
lform = lfmt1_(&comtrill_1.ornhshft[iudorn - 1]);
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lform;
ici__1.iciunit = noteq;
/* Writing concatenation */
i__4[0] = 2, a__2[0] = "(f";
i__1 = lform + 48;
chax_(ch__1, (ftnlen)1, &i__1);
i__4[1] = 1, a__2[1] = ch__1;
i__4[2] = 3, a__2[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)6),
ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comtrill_1.ornhshft[iudorn - 1], (ftnlen)
sizeof(real));
e_wsfi();
/* Writing concatenation */
i__5[0] = 1, a__3[0] = sq;
i__5[1] = 8, a__3[1] = "roffset{";
i__5[2] = lform, a__3[2] = noteq;
i__5[3] = 2, a__3[3] = "}{";
i__5[4] = lnote, a__3[4] = notexq;
i__5[5] = 1, a__3[5] = "}";
s_cat(notexq, a__3, i__5, &c__6, (ftnlen)79);
lnote = lnote + lform + 12;
comtrill_1.ornhshft[iudorn - 1] = 0.f;
comtrill_1.kudorn[iudorn - 1] = bit_clear(comtrill_1.kudorn[
iudorn - 1],31);
}
}
/* Zero out the bit for ornament just dealt with. */
*iornq = bit_clear(*iornq,ibit);
if (*lout == 0) {
s_copy(outq, notexq, (ftnlen)79, lnote);
} else {
/* Writing concatenation */
i__3[0] = *lout, a__1[0] = outq;
i__3[1] = lnote, a__1[1] = notexq;
s_cat(outq, a__1, i__3, &c__2, (ftnlen)79);
}
*lout += lnote;
/* Check bits 0-21, go back if any are still set */
if ((*iornq & 4194303) > 0) {
goto L2;
}
if (usehornb) {
++nornb[*ivx];
}
return 0;
} /* putorn_ */
/* Subroutine */ int putshft_(integer *ivx, logical *onoff, char *soutq,
integer *lsout, ftnlen soutq_len)
{
/* System generated locals */
address a__1[3], a__2[4];
integer i__1[3], i__2, i__3[4];
real r__1;
char ch__1[1], ch__2[6], ch__3[88];
icilist ici__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
static char sq[1];
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer ifmt;
static real xoff;
extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char notexq[80];
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
/* Start user-defined offsets X(...): or X(...)S */
if (*onoff) {
++comudsp_1.nudoff[*ivx - 1];
}
/* Xoff is in pts. Round off to nearest .1. Will use at end of shift. */
xoff = comudsp_1.udoff[*ivx + comudsp_1.nudoff[*ivx - 1] * 24 - 25];
r__1 = (integer) (dabs(xoff) * 10.f + .5f) / 10.f;
xoff = r_sign(&r__1, &xoff);
if (! (*onoff)) {
xoff = -xoff;
}
if (xoff < -9.95f) {
ifmt = 5;
} else if (xoff < -.95f || xoff > 9.95f) {
ifmt = 4;
} else {
ifmt = 3;
}
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 80;
ici__1.iciunit = notexq;
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "(f";
i__2 = ifmt + 48;
chax_(ch__1, (ftnlen)1, &i__2);
i__1[1] = 1, a__1[1] = ch__1;
i__1[2] = 3, a__1[2] = ".1)";
ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)6), ch__2);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&xoff, (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__3[0] = 1, a__2[0] = sq;
i__3[1] = 4, a__2[1] = "off{";
i__3[2] = ifmt, a__2[2] = notexq;
i__3[3] = 3, a__2[3] = "pt}";
s_cat(ch__3, a__2, i__3, &c__4, (ftnlen)88);
i__2 = ifmt + 8;
addstr_(ch__3, &i__2, soutq, lsout, ifmt + 8, (ftnlen)80);
return 0;
} /* putshft_ */
/* Subroutine */ int puttitle_(integer *inhnoh, real *xnsttop, real *etatop,
char *sq, real *etait, real *etatc, real *etacs1, integer *nv,
logical *vshrink, char *sepsymq, ftnlen sq_len, ftnlen sepsymq_len)
{
/* System generated locals */
address a__1[2], a__2[3], a__3[3], a__4[4];
integer i__1[2], i__2, i__3[3], i__4, i__5[3], i__6[4];
real r__1;
char ch__1[8], ch__2[1], ch__3[10], ch__4[148], ch__5[129], ch__6[133];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
double r_lg10(real *);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int writflot_(real *, char *, integer *, ftnlen);
static integer iv, lcq, ndig;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static real xcsil, xtcil, vskil, xitil, glueil;
extern integer lenstr_(char *, integer *, ftnlen);
extern /* Subroutine */ int printl_(char *, ftnlen);
static char notexq[127];
static integer lenline;
/* Fortran I/O blocks */
static cilist io___1562 = { 0, 11, 0, "(a)", 0 };
static cilist io___1565 = { 0, 11, 0, "(a)", 0 };
static cilist io___1568 = { 0, 11, 0, "(a)", 0 };
/* Called once per page, at top of page! If vshrink, only called for p.1. */
/* Actual titles only allowed on p.1. (set by headlog). */
/* 3/18/01: The above comment is probably bogus...can use Tt on later pages. */
/* Parameter adjustments */
--sepsymq;
/* Function Body */
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 6, a__1[1] = "znotes";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline = 7;
i__2 = *nv - 1;
for (iv = 1; iv <= i__2; ++iv) {
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = sepsymq + iv;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
++lenline;
/* L22: */
}
/* Writing concatenation */
i__3[0] = lenline, a__2[0] = notexq;
i__3[1] = 1, a__2[1] = sq;
i__3[2] = 10, a__2[2] = "zcharnote{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)127);
lenline += 11;
if (! comtitl_1.headlog) {
comtitl_1.inhead = *inhnoh;
}
if (*vshrink && comlast_1.usevshrink) {
comtitl_1.inhead = 16;
}
r__1 = comtitl_1.inhead + .01f;
ndig = (integer) r_lg10(&r__1) + 1;
i__2 = lenline;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lenline + ndig + 10 - i__2;
ici__1.iciunit = notexq + i__2;
/* Writing concatenation */
i__3[0] = 2, a__2[0] = "(i";
i__4 = ndig + 48;
chax_(ch__2, (ftnlen)1, &i__4);
i__3[1] = 1, a__2[1] = ch__2;
i__3[2] = 5, a__2[2] = ",a10)";
ici__1.icifmt = (s_cat(ch__1, a__2, i__3, &c__3, (ftnlen)8), ch__1);
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&comtitl_1.inhead, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__5[0] = 2, a__3[0] = "}{";
i__5[1] = 1, a__3[1] = sq;
i__5[2] = 7, a__3[2] = "titles{";
s_cat(ch__3, a__3, i__5, &c__3, (ftnlen)10);
do_fio(&c__1, ch__3, (ftnlen)10);
e_wsfi();
lenline = lenline + ndig + 10;
/* Vertical skip at top of page (\Il) = etatop*glueil. Needed whether */
/* headers are present or not. */
glueil = *xnsttop / *etatop;
vskil = *etatop * glueil;
if (*vshrink && comlast_1.usevshrink) {
vskil = 2.f;
}
writflot_(&vskil, notexq, &lenline, (ftnlen)127);
if (! comtitl_1.headlog) {
if (comlast_1.islast) {
s_wsfe(&io___1562);
/* Writing concatenation */
i__6[0] = lenline, a__4[0] = notexq;
i__6[1] = 17, a__4[1] = "}{}{0}{}{0}{}{0}}";
i__6[2] = 1, a__4[2] = sq;
i__6[3] = 3, a__4[3] = "en%";
s_cat(ch__4, a__4, i__6, &c__4, (ftnlen)148);
do_fio(&c__1, ch__4, lenline + 21);
e_wsfe();
}
} else {
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 2, a__1[1] = "}{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += 2;
lcq = lenstr_(comtitl_1.instrq, &c__120, (ftnlen)120);
if (lcq > 0) {
xitil = *etait * glueil;
if (*vshrink && comlast_1.usevshrink) {
xitil = 2.f;
}
/* Writing concatenation */
i__3[0] = lenline, a__2[0] = notexq;
i__3[1] = lcq, a__2[1] = comtitl_1.instrq;
i__3[2] = 2, a__2[2] = "}{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)127);
/* Null out instrument once used */
s_copy(comtitl_1.instrq, " ", (ftnlen)120, (ftnlen)1);
lenline = lenline + lcq + 2;
writflot_(&xitil, notexq, &lenline, (ftnlen)127);
} else {
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 3, a__1[1] = "}{0";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += 3;
}
if (comlast_1.islast) {
s_wsfe(&io___1565);
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 2, a__1[1] = "}%";
s_cat(ch__5, a__1, i__1, &c__2, (ftnlen)129);
do_fio(&c__1, ch__5, lenline + 2);
e_wsfe();
}
s_copy(notexq, "{", (ftnlen)127, (ftnlen)1);
lenline = 1;
lcq = lenstr_(comtitl_1.titleq, &c__120, (ftnlen)120);
if (lcq > 0) {
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = lcq, a__1[1] = comtitl_1.titleq;
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += lcq;
} else {
printl_(" ", (ftnlen)1);
printl_("WARNING", (ftnlen)7);
printl_(" In a title block, you have specified instrument and/or"
, (ftnlen)56);
printl_(" composer but no title for the piece.", (ftnlen)38);
}
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 2, a__1[1] = "}{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += 2;
xtcil = *etatc * glueil;
lcq = lenstr_(comtitl_1.compoq, &c__120, (ftnlen)120);
if (lcq == 0) {
xtcil *= 2;
}
if (*vshrink && comlast_1.usevshrink) {
xtcil = 2.f;
}
writflot_(&xtcil, notexq, &lenline, (ftnlen)127);
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 2, a__1[1] = "}{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += 2;
if (lcq > 0) {
/* Writing concatenation */
i__3[0] = lenline, a__2[0] = notexq;
i__3[1] = lcq, a__2[1] = comtitl_1.compoq;
i__3[2] = 2, a__2[2] = "}{";
s_cat(notexq, a__2, i__3, &c__3, (ftnlen)127);
lenline = lenline + 2 + lcq;
/* Null out compoq so it does not get written later */
s_copy(comtitl_1.compoq, " ", (ftnlen)120, (ftnlen)1);
xcsil = *etacs1 * glueil;
if (*vshrink && comlast_1.usevshrink) {
xcsil = 2.f;
}
writflot_(&xcsil, notexq, &lenline, (ftnlen)127);
} else {
/* Writing concatenation */
i__1[0] = lenline, a__1[0] = notexq;
i__1[1] = 3, a__1[1] = "}{0";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)127);
lenline += 3;
}
if (comlast_1.islast) {
s_wsfe(&io___1568);
/* Writing concatenation */
i__6[0] = lenline, a__4[0] = notexq;
i__6[1] = 2, a__4[1] = "}}";
i__6[2] = 1, a__4[2] = sq;
i__6[3] = 3, a__4[3] = "en%";
s_cat(ch__6, a__4, i__6, &c__4, (ftnlen)133);
do_fio(&c__1, ch__6, lenline + 6);
e_wsfe();
}
comtitl_1.headlog = FALSE_;
}
return 0;
} /* puttitle_ */
/* Subroutine */ int putxtn_(integer *ntupv, integer *iflop, integer *multb,
integer *iud, real *wheadpt, real *poenom, integer *nolev1, integer *
islope, real *slfac, real *xnlmid, integer *islur, integer *lnote,
char *notexq, integer *ncmid, integer *nlnum, real *eloff, integer *
iup, integer *irest, logical *usexnumt, ftnlen notexq_len)
{
/* System generated locals */
address a__1[2], a__2[3];
integer i__1[2], i__2[3], i__3;
real r__1;
char ch__1[1];
icilist ici__1;
/* Builtin functions */
integer i_nint(real *), lbit_shift(integer, integer);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char noteq[8];
extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer
*, ftnlen);
static integer lnoten, istrtn;
/* Places digit for xtuplet. */
if (*iflop != 0 && *multb > 0) {
/* Number goes on beam side, move R/L by .5 wheadpt for upper/lower */
*eloff -= *iud * .5f * *wheadpt / *poenom;
/* Number goes on beam side, must use beam parameters to set pos'n */
*nlnum = *nolev1 + *islope / *slfac * *eloff + *iup * (*multb + 8);
if (*multb >= 2) {
*nlnum += *iup;
}
} else {
r__1 = *xnlmid - 1 + *iud * 3 + *iflop * 11;
*nlnum = i_nint(&r__1);
}
if (! bit_test(*islur,31)) {
/* Only print number when wanted. First check vert, horiz offset */
if (bit_test(*irest,1)) {
*nlnum = *nlnum + (31 & lbit_shift(*irest, (ftnlen)-2)) - 16;
}
if (bit_test(*irest,7)) {
*eloff += ((31 & lbit_shift(*irest, (ftnlen)-9)) * .1f - 1.6f) * *
wheadpt / *poenom;
}
if (! (*usexnumt)) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 5, a__1[1] = "xnum{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote = 10;
istrtn = 7;
} else {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__1[0] = 1, a__1[0] = ch__1;
i__1[1] = 6, a__1[1] = "xnumt{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote = 11;
istrtn = 8;
}
if (*eloff < .995f) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = notexq + (istrtn - 1);
ici__1.icifmt = "(i1,f3.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*eloff), (ftnlen)sizeof(real));
e_wsfi();
} else if (*eloff < 9.995f) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = notexq + (istrtn - 1);
ici__1.icifmt = "(f4.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*eloff), (ftnlen)sizeof(real));
e_wsfi();
} else {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 5;
ici__1.iciunit = notexq + (istrtn - 1);
ici__1.icifmt = "(f5.2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*eloff), (ftnlen)sizeof(real));
e_wsfi();
++(*lnote);
}
notefq_(noteq, &lnoten, nlnum, ncmid, (ftnlen)8);
/* Writing concatenation */
i__2[0] = *lnote, a__2[0] = notexq;
i__2[1] = 1, a__2[1] = "}";
i__2[2] = lnoten, a__2[2] = noteq;
s_cat(notexq, a__2, i__2, &c__3, (ftnlen)79);
*lnote = *lnote + 1 + lnoten;
if (*ntupv < 10) {
i__3 = *lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 1 - i__3;
ici__1.iciunit = notexq + i__3;
ici__1.icifmt = "(i1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*ntupv), (ftnlen)sizeof(integer));
e_wsfi();
++(*lnote);
} else {
/* Writing concatenation */
i__1[0] = *lnote, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = "{";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
i__3 = *lnote + 1;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lnote + 3 - i__3;
ici__1.iciunit = notexq + i__3;
ici__1.icifmt = "(i2)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*ntupv), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = *lnote + 3, a__1[0] = notexq;
i__1[1] = 1, a__1[1] = "}";
s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79);
*lnote += 4;
}
}
return 0;
} /* putxtn_ */
/* Subroutine */ int read10_(char *string, logical *lastchar, ftnlen
string_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ip1, ip2;
extern /* Subroutine */ int getbuf_(char *, ftnlen);
if (! commac_1.mplay) {
if (inbuff_1.ilbuf > inbuff_1.nlbuf) {
goto L999;
}
getbuf_(string, string_len);
return 0;
L999:
*lastchar = TRUE_;
return 0;
} else {
/* Play a macro. Set pointer to first character needed in buffer */
if (c1ommac_1.ilmac == c1ommac_1.il1mac[commac_1.macnum - 1]) {
/* Getting first line of macro */
ip1 = c1ommac_1.ip1mac[commac_1.macnum - 1];
c1ommac_1.iplmac = ip1 - c1ommac_1.ic1mac[commac_1.macnum - 1];
} else if (c1ommac_1.ilmac <= c1ommac_1.il2mac[commac_1.macnum - 1]) {
/* Beyond first line of macro. Advance line-start pointer. */
c1ommac_1.iplmac += inbuff_1.lbuf[c1ommac_1.ilmac - 2];
ip1 = c1ommac_1.iplmac + 1;
} else {
/* Beyond last line of macro. Terminate it! */
commac_1.mplay = FALSE_;
commac_1.endmac = TRUE_;
return 0;
}
if (c1ommac_1.ilmac == c1ommac_1.il2mac[commac_1.macnum - 1]) {
/* Getting last line of macro. */
ip2 = c1ommac_1.ip2mac[commac_1.macnum - 1];
} else {
/* Getting line before last line of macro. */
ip2 = c1ommac_1.iplmac + inbuff_1.lbuf[c1ommac_1.ilmac - 1];
}
if (ip2 >= ip1) {
s_copy(string, inbuff_1.bufq + (ip1 - 1), string_len, ip2 - (ip1
- 1));
} else {
/* Kluge for when macro start is on a line by itself */
s_copy(string, " ", string_len, (ftnlen)1);
}
++c1ommac_1.ilmac;
return 0;
}
return 0;
} /* read10_ */
doublereal readin_(char *lineq, integer *iccount, integer *nline, ftnlen
lineq_len)
{
/* System generated locals */
address a__1[3];
integer i__1[3];
real ret_val;
char ch__1[27], ch__2[6], ch__3[1];
icilist ici__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen), e_wsle(void),
s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
;
/* Local variables */
static integer i1, i2, icf;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char durq[1];
extern /* Subroutine */ int stop1_(void), getbuf_(char *, ftnlen),
getchar_(char *, integer *, char *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1577 = { 0, 6, 0, 0, 0 };
/* Reads a piece of setup data from file lineq, gets a new lineq from */
/* file 10 (jobname.pmx) and increments nline if needed, passes over */
/* comment lines */
L4:
if (*iccount == 128) {
L1:
getbuf_(lineq, (ftnlen)128);
++(*nline);
if (*(unsigned char *)lineq == '%') {
goto L1;
}
*iccount = 0;
}
++(*iccount);
/* Find next non-blank or end of line */
for (*iccount = *iccount; *iccount <= 127; ++(*iccount)) {
if (*(unsigned char *)&lineq[*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_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* Remember that getchar 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___1577);
/* 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();
stop1_();
}
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 = lineq + (i1 - 1);
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "(f";
chax_(ch__3, (ftnlen)1, &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();
return ret_val;
} /* readin_ */
/* Subroutine */ int readmeter_(char *lineq, integer *iccount, integer *
mtrnum, integer *mtrden, ftnlen lineq_len)
{
/* System generated locals */
address a__1[3];
integer i__1, i__2[3];
char ch__1[4], ch__2[1];
icilist ici__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
;
/* Local variables */
static integer ns;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char durq[1];
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen);
i__1 = *iccount;
if (i_indx(lineq + i__1, "/", *iccount + 3 - i__1, (ftnlen)1) == 0) {
/* No slashes, so use old method */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '-') {
/* Negative numerator is used only to printed; signals vertical slash */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
*mtrnum = -(*(unsigned char *)durq - 48);
} else if (*(unsigned char *)durq == 'o') {
/* Numerator is EXACTLY 1 */
*mtrnum = 1;
} else {
*mtrnum = *(unsigned char *)durq - 48;
if (*mtrnum == 1) {
/* Numerator is >9 */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
*mtrnum = *(unsigned char *)durq - 38;
}
}
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == 'o') {
*mtrden = 1;
} else {
*mtrden = *(unsigned char *)durq - 48;
if (*mtrden == 1) {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
*mtrden = *(unsigned char *)durq - 38;
}
}
} else {
/* Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' */
++(*iccount);
ns = i_indx(lineq + (*iccount - 1), "/", 128 - (*iccount - 1), (
ftnlen)1);
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *iccount + ns - 2 - (*iccount - 1);
ici__1.iciunit = lineq + (*iccount - 1);
/* Writing concatenation */
i__2[0] = 2, a__1[0] = "(i";
i__1 = ns + 47;
chax_(ch__2, (ftnlen)1, &i__1);
i__2[1] = 1, a__1[1] = ch__2;
i__2[2] = 1, a__1[2] = ")";
ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1);
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&(*mtrnum), (ftnlen)sizeof(integer));
e_rsfi();
/* Reset iccount to start of second integer */
*iccount += ns;
/* There must be either a slash or a blank at pos'n 2 or 3 */
ns = i_indx(lineq + (*iccount - 1), "/", (ftnlen)3, (ftnlen)1);
if (ns == 0) {
ns = i_indx(lineq + (*iccount - 1), " ", (ftnlen)3, (ftnlen)1);
}
ici__1.icierr = 0;
ici__1.iciend = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *iccount + ns - 2 - (*iccount - 1);
ici__1.iciunit = lineq + (*iccount - 1);
/* Writing concatenation */
i__2[0] = 2, a__1[0] = "(i";
i__1 = ns + 47;
chax_(ch__2, (ftnlen)1, &i__1);
i__2[1] = 1, a__1[1] = ch__2;
i__2[2] = 1, a__1[2] = ")";
ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1);
s_rsfi(&ici__1);
do_fio(&c__1, (char *)&(*mtrden), (ftnlen)sizeof(integer));
e_rsfi();
/* Set iccount to last character used */
*iccount = *iccount + ns - 1;
}
return 0;
} /* readmeter_ */
/* Subroutine */ int readnum_(char *lineq, integer *iccount, char *durq, real
*fnum, ftnlen lineq_len, ftnlen durq_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 i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen), e_wsle(void),
s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
;
/* Local variables */
static integer i1, i2, icf;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
extern /* Subroutine */ int stop1_(void), getchar_(char *, integer *,
char *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1583 = { 0, 6, 0, 0, 0 };
/* This reads a number starting at position iccount. Remember that on exit, */
/* getchar leaves iccount at the last character retrieved. So must only */
/* call this routine *after* detecting a number or decimal. */
/* On exit, durq is next character after end of number. */
i1 = *iccount;
L1:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) > 0) {
goto L1;
}
i2 = *iccount - 1;
if (i2 < i1) {
s_wsle(&io___1583);
/* 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();
stop1_();
} else if (*(unsigned char *)&lineq[i1 - 1] == '.' && *(unsigned char *)&
lineq[i2 - 1] == '.') {
--i2;
--(*iccount);
}
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 = lineq + (i1 - 1);
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "(f";
chax_(ch__3, (ftnlen)1, &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 *)&(*fnum), (ftnlen)sizeof(real));
e_rsfi();
return 0;
} /* readnum_ */
/* Subroutine */ int setbits_(integer *isdata, integer *iwidbit, integer *
ishift, integer *ivalue)
{
/* Builtin functions */
integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
do_lio(integer *, integer *, char *, ftnlen), s_wsfe(cilist *),
do_fio(integer *, char *, ftnlen), e_wsfe(void), lbit_shift(
integer, integer);
/* Local variables */
static integer ibase;
/* Fortran I/O blocks */
static cilist io___1586 = { 0, 6, 0, 0, 0 };
static cilist io___1587 = { 0, 6, 0, 0, 0 };
static cilist io___1588 = { 0, 15, 0, "(/,a)", 0 };
/* Sets iwidbits of isdata, shifted by ishift, to ivalue */
ibase = pow_ii(&c__2, iwidbit) - 1;
if (*ivalue > ibase) {
s_wsle(&io___1586);
e_wsle();
s_wsle(&io___1587);
do_lio(&c__9, &c__1, "WARNING in setbits: ivalue > ibase", (ftnlen)34)
;
e_wsle();
s_wsfe(&io___1588);
do_fio(&c__1, "WARNING in setbits: ivalue > ibase", (ftnlen)34);
e_wsfe();
}
*isdata = ~ lbit_shift(ibase, *ishift) & *isdata;
*isdata |= lbit_shift(*ivalue, *ishift);
return 0;
} /* setbits_ */
/* Subroutine */ int setbm2_(real *xelsk, integer *nnb, real *sumx, real *
sumy, integer *ipb, integer *islope, integer *nolev1)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
integer i_nint(real *), i_sign(integer *, integer *);
/* Local variables */
static real em;
static integer ibc, inb, iul;
static real beta, smin, delta, ybeam, ynote, sumxx, sumxy, deficit;
/* The MEAN SQUARE slope algorithm */
/* Parameter adjustments */
--ipb;
--xelsk;
/* Function Body */
ibc = all_1.ibmcnt[commvl_1.ivx - 1];
sumxx = 0.f;
sumxy = 0.f;
i__1 = *nnb;
for (inb = 1; inb <= i__1; ++inb) {
/* Computing 2nd power */
r__1 = xelsk[inb];
sumxx += r__1 * r__1;
sumxy += xelsk[inb] * all_1.nolev[commvl_1.ivx + ipb[inb] * 24 - 25];
/* L2: */
}
delta = *nnb * sumxx - *sumx * *sumx;
em = (*nnb * sumxy - *sumx * *sumy) / delta;
r__1 = em * .5f * all_1.slfac;
*islope = i_nint(&r__1);
if (abs(*islope) > 9) {
*islope = i_sign(&c__9, islope);
}
beta = (*sumy - *islope / all_1.slfac * *sumx) / *nnb;
*nolev1 = i_nint(&beta);
/* Check if any stems are too short */
smin = 100.f;
iul = -1;
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u') {
iul = 1;
}
i__1 = *nnb;
for (inb = 1; inb <= i__1; ++inb) {
ybeam = *nolev1 + iul * all_1.stemlen + *islope * xelsk[inb] /
all_1.slfac;
ynote = (real) all_1.nolev[commvl_1.ivx + ipb[inb] * 24 - 25];
/* Computing MIN */
r__1 = smin, r__2 = iul * (ybeam - ynote);
smin = dmin(r__1,r__2);
/* L4: */
}
if (smin < all_1.stemmin) {
deficit = all_1.stemmin - smin;
r__1 = *nolev1 + iul * deficit;
*nolev1 = i_nint(&r__1);
}
return 0;
} /* setbm2_ */
/* Subroutine */ int setmac_(char *lineq, integer *iccount, integer *ibarcnt,
integer *ibaroff, integer *nbars, char *charq, char *durq, integer *
ivx, integer *nline, ftnlen lineq_len, ftnlen charq_len, ftnlen
durq_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen), i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *)
;
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real fnum;
static integer ndxm;
extern /* Subroutine */ int stop1_(void), m1rec1_(char *, integer *,
integer *, integer *, integer *, integer *, ftnlen), getbuf_(char
*, ftnlen), errmsg_(char *, integer *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen), g1etchar_(char *, integer *, char *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1601 = { 0, 6, 0, 0, 0 };
static cilist io___1602 = { 0, 6, 0, 0, 0 };
static cilist io___1603 = { 0, 6, 0, 0, 0 };
/* Macro action */
g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)charq == 'S' && *ivx != 1) {
s_wsle(&io___1601);
e_wsle();
s_wsle(&io___1602);
e_wsle();
s_wsle(&io___1603);
do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen)25);
e_wsle();
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "\"MS...\" only put in parts by scor2"
"prt if in voice #1!", (ftnlen)128, (ftnlen)53);
}
if (i_indx("RSP ", charq, (ftnlen)4, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Illegal character after \"M\" (macro"
")!", (ftnlen)128, (ftnlen)36);
stop1_();
} else if (*(unsigned char *)charq != ' ') {
/* Record or playback a macro. Get the number of the macro. */
g1etchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Must input number after \"MR\""
",\"MP\", or \"MS\"!", (ftnlen)128, (ftnlen)43);
stop1_();
}
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
commac_1.macnum = i_nint(&fnum);
if (*(unsigned char *)durq != ' ') {
i__1 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, iccount, &i__1, "Macro number must be followed by"
" a blank!", (ftnlen)128, (ftnlen)41);
stop1_();
}
if (i_indx("RS", charq, (ftnlen)2, (ftnlen)1) > 0) {
/* Record or save a macro */
if (commac_1.macnum < 1 || commac_1.macnum > 20) {
i__1 = *iccount - 1;
i__2 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__1, &i__2, "Macro number not in range 1-20!"
, (ftnlen)128, (ftnlen)31);
stop1_();
/* else if (btest(macuse,macnum)) then */
/* print* */
/* print*,'WARNING: Redefining macro # ',macnum */
}
commac_1.macuse = bit_set(commac_1.macuse,commac_1.macnum);
if (*(unsigned char *)charq == 'R') {
m1rec1_(lineq, iccount, ibarcnt, ibaroff, nbars, &ndxm, (
ftnlen)128);
} else if (*(unsigned char *)charq == 'S') {
/* Save (Record but don't activate) */
L1:
m1rec1_(lineq, iccount, ibarcnt, ibaroff, nbars, &ndxm, (
ftnlen)128);
if (commac_1.mrecord) {
getbuf_(lineq, (ftnlen)128);
++(*nline);
*iccount = 0;
goto L1;
}
*iccount = *iccount + ndxm + 1;
}
} else {
/* Playback the macro */
if (! bit_test(commac_1.macuse,commac_1.macnum)) {
i__1 = *iccount - 1;
i__2 = *ibarcnt - *ibaroff + *nbars + 1;
errmsg_(lineq, &i__1, &i__2, "Cannot play a macro that has n"
"ot been recorded!", (ftnlen)128, (ftnlen)47);
stop1_();
}
commac_1.icchold = *iccount;
s_copy(commac_1.lnholdq, lineq, (ftnlen)128, (ftnlen)128);
*iccount = 128;
commac_1.mplay = TRUE_;
c1ommac_1.ilmac = c1ommac_1.il1mac[commac_1.macnum - 1];
}
}
return 0;
} /* setmac_ */
/* Subroutine */ int setmeter_(integer *mtrnuml, integer *mtrdenl, integer *
ibmtyp, integer *ibmrep)
{
/* Sets last 2 args depending on 1st 2, (logical) num, denom. */
/* ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. */
/* 1: all duple meters */
/* 2: triple w/ denom=4, subdivide in groups of 2 8ths */
/* 3: triple w/ denom=8, subdivide in groups of 3 8ths */
/* Note that lenbar is set at top or when 'm' symbol is read in getnote */
if (*mtrdenl == 4) {
if (*mtrnuml % 3 == 0) {
*ibmtyp = 2;
*ibmrep = *mtrnuml / 3;
} else {
*ibmtyp = 1;
*ibmrep = *mtrnuml / 2;
}
} else if (*mtrdenl == 2) {
*ibmtyp = 1;
if (*mtrnuml == 3) {
*ibmrep = 3;
} else {
*ibmrep = (*mtrnuml << 1) / *mtrdenl;
}
} else {
/* Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 */
*ibmtyp = 3;
*ibmrep = *mtrnuml / 3;
}
/* Reset so we don't keep writing new meters */
*mtrnuml = 0;
/* Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter */
*ibmrep = max(*ibmrep,1);
return 0;
} /* setmeter_ */
/* Subroutine */ int setupb_(real *xelsk, integer *nnb, real *sumx, real *
sumy, integer *ipb, real *smed, integer *ixrest)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double r_sign(real *, real *);
integer i_nint(real *), i_sign(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t;
static integer n1, ip;
static real yb1;
static integer ibc, inb, jnb;
static real off;
static integer nsc, iul;
static real syb, sum, ssq, off1, off2;
static logical l1ng, l2ng;
static real beta, smin, eskz0;
static integer ipxt1;
extern integer ncmid_(integer *, integer *);
static real ybeam, xboff;
static integer ndoub;
static real slope[800];
static integer issbs;
static real ynote;
extern /* Subroutine */ int setbm2_(real *, integer *, real *, real *,
integer *, integer *, integer *);
static integer nscmid;
static real dnolev;
static integer iplast, nolevo;
static real xnolev2, deficit;
static integer ipxtmid;
/* The outer combo algorithm */
/* Parameter adjustments */
--ipb;
--xelsk;
/* Function Body */
ibc = all_1.ibmcnt[commvl_1.ivx - 1];
comxtup_2.nxtinbm[commvl_1.ivx - 1] = 0;
n1 = comipl2_1.ipl2[commvl_1.ivx + all_1.ibm1[commvl_1.ivx + ibc * 24 -
25] * 24 - 25];
/* Initialize counters used in this subroutine, and then later during actual */
/* beam drawing, to count later segments of single-slope beam groups */
comxtup_2.nssb[commvl_1.ivx - 1] = 0;
comxtup_2.issb[commvl_1.ivx - 1] = 0;
/* Set flag for xtup beam starting with rest (no others can start with rest) */
if (bit_test(all_1.irest[commvl_1.ivx + all_1.ipo[n1 - 1] * 24 - 25],0)) {
*ixrest = 1;
}
/* Figure how many elemskips to each note. Use the list, counting only non-rests. */
eskz0 = all_1.eskz[commvl_1.ivx + all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]
* 24 - 25];
*nnb = 0;
*sumx = 0.f;
*sumy = 0.f;
ipxt1 = 0;
iplast = all_1.ibm2[commvl_1.ivx + ibc * 24 - 25];
i__1 = iplast;
for (ip = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; ip <= i__1; ++ip) {
if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) {
++(*nnb);
ipb[*nnb] = ip;
xelsk[*nnb] = all_1.eskz[commvl_1.ivx + ip * 24 - 25] - eskz0;
*sumx += xelsk[*nnb];
*sumy += all_1.nolev[commvl_1.ivx + ipb[*nnb] * 24 - 25];
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],21)) {
/* This is the starting note of later segment of single-slope beam group */
/* Temporarily store ip here. */
++comxtup_2.nssb[commvl_1.ivx - 1];
comxtup_2.lev1ssb[commvl_1.ivx + comxtup_2.nssb[commvl_1.ivx
- 1] * 24 - 25] = *nnb;
}
}
/* New xtup stuff here. Final object is to get distance from start of xtup */
/* to number. xtinbm counts xtups in this beam only. mtupv is the printed */
/* number. ntupv is number of notes in xtup, and is only used to get */
/* eloff, the distance from start of xtup to the number. */
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],18)) {
++ndoub;
}
if (ipxt1 == 0 && all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) {
/* Xtup is starting here */
++comxtup_2.nxtinbm[commvl_1.ivx - 1];
ipxt1 = ip;
if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],18)) {
ndoub = 1;
} else {
ndoub = 0;
}
} else if (ipxt1 > 0 && all_1.nodur[commvl_1.ivx + ip * 24 - 25] > 0)
{
/* Xtup ends here. Set total number of notes in xtup. */
comxtup_2.ntupv[commvl_1.ivx + comxtup_2.nxtinbm[commvl_1.ivx - 1]
* 24 - 25] = ip + 1 - ipxt1;
/* Set printed number for embedded xtup. */
comxtup_2.mtupv[commvl_1.ivx + comxtup_2.nxtinbm[commvl_1.ivx - 1]
* 24 - 25] = comxtup_2.ntupv[commvl_1.ivx +
comxtup_2.nxtinbm[commvl_1.ivx - 1] * 24 - 25] + ndoub;
/* Middle note of xtup if ntupv odd, note to left of gap if even. */
ipxtmid = (ip + ipxt1) / 2;
comxtup_2.eloff[commvl_1.ivx + comxtup_2.nxtinbm[commvl_1.ivx - 1]
* 24 - 25] = comeskz2_1.eskz2[commvl_1.ivx + ipxtmid *
24 - 25] - comeskz2_1.eskz2[commvl_1.ivx + ipxt1 * 24 -
25];
if (comxtup_2.ntupv[commvl_1.ivx + comxtup_2.nxtinbm[commvl_1.ivx
- 1] * 24 - 25] % 2 == 0) {
comxtup_2.eloff[commvl_1.ivx + comxtup_2.nxtinbm[commvl_1.ivx
- 1] * 24 - 25] += (comeskz2_1.eskz2[commvl_1.ivx + (
ipxtmid + 1) * 24 - 25] - comeskz2_1.eskz2[
commvl_1.ivx + ipxtmid * 24 - 25]) * .5f;
}
ipxt1 = 0;
}
/* L2: */
}
/* Reset nxtinbm for use as counter as #'s are posted by putxtn(..) */
comxtup_2.nxtinbm[commvl_1.ivx - 1] = 0;
*smed = 0.f;
if (! bit_test(all_1.islur[commvl_1.ivx + ipb[1] * 24 - 25],2)) {
/* No forced 0 slope */
if (*nnb == 1) {
goto L6;
}
nsc = 0;
i__1 = *nnb - 1;
for (inb = 1; inb <= i__1; ++inb) {
i__2 = *nnb;
for (jnb = inb + 1; jnb <= i__2; ++jnb) {
++nsc;
slope[nsc - 1] = (all_1.nolev[commvl_1.ivx + ipb[jnb] * 24 -
25] - all_1.nolev[commvl_1.ivx + ipb[inb] * 24 - 25])
/ (xelsk[jnb] - xelsk[inb]);
if ((r__1 = slope[nsc - 1], dabs(r__1)) < 1e-4f) {
++nsc;
slope[nsc - 1] = slope[nsc - 2];
++nsc;
slope[nsc - 1] = slope[nsc - 2];
}
/* L5: */
}
}
if (nsc == 1) {
*smed = slope[0];
goto L6;
}
nscmid = nsc / 2 + 1;
i__2 = nscmid;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = nsc;
for (j = i__ + 1; j <= i__1; ++j) {
if (slope[j - 1] < slope[i__ - 1]) {
t = slope[j - 1];
slope[j - 1] = slope[i__ - 1];
slope[i__ - 1] = t;
}
/* L7: */
}
}
*smed = slope[nscmid - 1];
if (nsc == nsc / 2 << 1) {
/* Even number of slopes in the list, so median is ambiguous */
if ((r__2 = slope[nscmid - 2], dabs(r__2)) < (r__1 = slope[nscmid
- 1], dabs(r__1)) - comtol_1.tol) {
/* Lower-numbered one is truly less in absolute value, so use it */
*smed = slope[nscmid - 2];
} else if ((r__1 = slope[nscmid - 2] + slope[nscmid - 1], dabs(
r__1)) < comtol_1.tol) {
/* Two slopes are effectively equal. Take the one with sign of the average */
sum = 0.f;
i__1 = nsc;
for (i__ = 1; i__ <= i__1; ++i__) {
sum += slope[i__ - 1];
/* L1: */
}
*smed = r_sign(smed, &sum);
}
}
L6:
r__1 = *smed * .5f * all_1.slfac;
comxtup_2.islope[commvl_1.ivx - 1] = i_nint(&r__1);
if ((i__1 = comxtup_2.islope[commvl_1.ivx - 1], abs(i__1)) > 9) {
comxtup_2.islope[commvl_1.ivx - 1] = i_sign(&c__9, &
comxtup_2.islope[commvl_1.ivx - 1]);
}
} else {
/* Forced horizontal beam */
comxtup_2.islope[commvl_1.ivx - 1] = 0;
}
beta = (*sumy - comxtup_2.islope[commvl_1.ivx - 1] / all_1.slfac * *sumx)
/ *nnb;
/* If ixrest>0, this is a virtual nolev1 at location of rest. Will first use */
/* as is for placing xtup number and/or bracket, then reset it for start of */
/* actual beam */
comxtup_2.nolev1[commvl_1.ivx - 1] = i_nint(&beta);
/* Check if any stems are too short */
smin = 100.f;
iul = -1;
if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u') {
iul = 1;
}
ssq = 0.f;
syb = 0.f;
/* yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) */
yb1 = comxtup_2.nolev1[commvl_1.ivx - 1] + iul * (all_1.stemlen +
combmh_1.bmhgt * ((15 & all_1.mult[commvl_1.ivx + ipb[1] * 24 -
25]) - 9));
i__1 = *nnb;
for (inb = 1; inb <= i__1; ++inb) {
ybeam = yb1 + comxtup_2.islope[commvl_1.ivx - 1] * xelsk[inb] /
all_1.slfac - iul * combmh_1.bmhgt * ((15 & all_1.mult[
commvl_1.ivx + ipb[inb] * 24 - 25]) - 9);
/* * -iul*bmhgt*(mult(ivx,ipb(inb))-1) */
syb += ybeam;
ynote = (real) all_1.nolev[commvl_1.ivx + ipb[inb] * 24 - 25];
off = ybeam - ynote;
if (inb == 1) {
off1 = off;
} else if (inb == *nnb) {
off2 = off;
}
ssq += off * off;
/* Computing MIN */
r__1 = smin, r__2 = iul * off;
smin = dmin(r__1,r__2);
/* L4: */
}
dnolev = 0.f;
if (smin < all_1.stemmin) {
deficit = all_1.stemmin - smin;
nolevo = comxtup_2.nolev1[commvl_1.ivx - 1];
r__1 = comxtup_2.nolev1[commvl_1.ivx - 1] + iul * deficit;
comxtup_2.nolev1[commvl_1.ivx - 1] = i_nint(&r__1);
dnolev = (real) (comxtup_2.nolev1[commvl_1.ivx - 1] - nolevo);
off1 += dnolev;
off2 += dnolev;
}
/* Computing 2nd power */
r__1 = dnolev;
ssq = ssq + dnolev * 2 * (syb - *sumy) + r__1 * r__1;
if (! comxtup_2.vxtup[commvl_1.ivx - 1] && sqrt(ssq / *nnb) >
all_1.stemmax && (dabs(off1) < all_1.stemmax || dabs(off2) <
all_1.stemmax) && ! bit_test(all_1.islur[commvl_1.ivx + ipb[1] *
24 - 25],2)) {
/* The first check is to save trouble of putting xtup's in setbm2. */
/* The penultimate check is that first and last stems aren't both excessive. */
/* The last check is that a 0 slope has not been forced */
setbm2_(&xelsk[1], nnb, sumx, sumy, &ipb[1], &comxtup_2.islope[
commvl_1.ivx - 1], &comxtup_2.nolev1[commvl_1.ivx - 1]);
}
/* Check if beam starts or ends too high or low. */
/* xboff = bmhgt*(mult(ivx,ipb(1))-1) */
xboff = combmh_1.bmhgt * ((15 & all_1.mult[commvl_1.ivx + ipb[1] * 24 -
25]) - 9);
l1ng = iul * (comxtup_2.nolev1[commvl_1.ivx - 1] - ncmid_(&all_1.iv, &ipb[
1])) + xboff + 7 < 0.f;
xnolev2 = comxtup_2.nolev1[commvl_1.ivx - 1] + comxtup_2.islope[
commvl_1.ivx - 1] / all_1.slfac * xelsk[*nnb];
l2ng = iul * (xnolev2 - ncmid_(&all_1.iv, &ipb[*nnb])) + xboff + 7 < 0.f;
if (l1ng || l2ng) {
/* Need to correct start or stop, also slope */
if (l1ng) {
r__1 = ncmid_(&all_1.iv, &ipb[1]) - (xboff + 7.f) * iul;
comxtup_2.nolev1[commvl_1.ivx - 1] = i_nint(&r__1);
}
if (l2ng) {
r__1 = ncmid_(&all_1.iv, &ipb[*nnb]) - (xboff + 7.f) * iul;
xnolev2 = (real) i_nint(&r__1);
}
/* Since one or the other end has changed, need to change slope */
if (! bit_test(all_1.islur[commvl_1.ivx + ipb[1] * 24 - 25],2)) {
r__1 = all_1.slfac * (xnolev2 - comxtup_2.nolev1[commvl_1.ivx - 1]
) / xelsk[*nnb];
comxtup_2.islope[commvl_1.ivx - 1] = i_nint(&r__1);
}
}
if (comxtup_2.nssb[commvl_1.ivx - 1] > 0) {
/* This is a single-slope beam group. Store start heights for later segs. */
i__1 = comxtup_2.nssb[commvl_1.ivx - 1];
for (issbs = 1; issbs <= i__1; ++issbs) {
comxtup_2.lev1ssb[commvl_1.ivx + issbs * 24 - 25] =
comxtup_2.nolev1[commvl_1.ivx - 1] + comxtup_2.islope[
commvl_1.ivx - 1] / all_1.slfac * xelsk[comxtup_2.lev1ssb[
commvl_1.ivx + issbs * 24 - 25]];
/* L3: */
}
}
return 0;
} /* setupb_ */
/* Subroutine */ int sortpoe_(integer *nsyst, real *poe, integer *ipoe)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer io1, io2, iord, itemp;
/* Initialize ipoe: */
/* Parameter adjustments */
--ipoe;
--poe;
/* Function Body */
i__1 = *nsyst;
for (iord = 1; iord <= i__1; ++iord) {
ipoe[iord] = iord;
/* L3: */
}
/* Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will */
/* be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. */
i__1 = *nsyst - 1;
for (io1 = 1; io1 <= i__1; ++io1) {
i__2 = *nsyst;
for (io2 = io1 + 1; io2 <= i__2; ++io2) {
if (poe[ipoe[io1]] > poe[ipoe[io2]]) {
/* Interchange the indices */
itemp = ipoe[io1];
ipoe[io1] = ipoe[io2];
ipoe[io2] = itemp;
}
/* L5: */
}
/* L4: */
}
return 0;
} /* sortpoe_ */
/* Subroutine */ int spsslur_(char *lineq, integer *iccount, integer *iv,
integer *kv, integer *ip, integer *isdat1, integer *isdat2, integer *
isdat3, integer *isdat4, integer *nsdat, logical *notcrd, integer *
nolev, char *starter, ftnlen lineq_len, ftnlen starter_len)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen), i_nint(real *);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static integer ilb12;
static real fnum;
static char dumq[1], durq[1];
static integer ihoff, isdat, ivoff, icurv1, idcode, nolevc, numint;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen), setbits_(integer *, integer *, integer *, integer *);
/* Reads in slur data. Record all h/v-shifts for non-chords, user-specified */
/* ones for chords. */
/* 5/26/02 This subr is called ONLY for postscript slurs. */
/* See subroutine doslur for bit values in isdat1,2,3 */
/* Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve */
/* Parameter adjustments */
--isdat4;
--isdat3;
--isdat2;
--isdat1;
/* Function Body */
numint = 0;
ivoff = 0;
ihoff = 0;
++(*nsdat);
if (*(unsigned char *)starter == '{' || *(unsigned char *)starter == '}')
{
isdat2[*nsdat] = bit_set(isdat2[*nsdat],3);
}
setbits_(&isdat1[*nsdat], &c__5, &c__13, iv);
i__1 = *kv - 1;
setbits_(&isdat1[*nsdat], &c__1, &c__12, &i__1);
setbits_(&isdat1[*nsdat], &c__8, &c__3, ip);
isdat3[*nsdat] = 0;
isdat4[*nsdat] = 0;
ilb12 = 0;
/* Get ID code */
/* flag for tweaks of 1st or 2nd (0|1) seg of linebreak s */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("uldtb+-hfnHps ", durq, (ftnlen)14, (ftnlen)1) > 0) {
/* Null id. Note for ps slurs, 'H' cannot be an ID */
--(*iccount);
if (*(unsigned char *)&lineq[*iccount - 1] == 't') {
idcode = 1;
} else {
idcode = 32;
}
} else {
/* Set explicit idcode */
idcode = *(unsigned char *)durq;
i__1 = *iccount - 2;
if (s_cmp(lineq + i__1, "t", *iccount - 1 - i__1, (ftnlen)1) == 0) {
/* Make t[ID] look like s[ID]t */
isdat2[*nsdat] = bit_set(isdat2[*nsdat],3);
}
}
setbits_(&isdat1[*nsdat], &c__7, &c__19, &idcode);
/* Set start/stop: look thru list from end for same idcode,iv,kv */
for (isdat = *nsdat - 1; isdat >= 1; --isdat) {
if (idcode == igetbits_(&isdat1[isdat], &c__7, &c__19) && *iv ==
igetbits_(&isdat1[isdat], &c__5, &c__13) && *kv - 1 ==
igetbits_(&isdat1[isdat], &c__1, &c__12)) {
/* Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. */
if (bit_test(isdat1[isdat],11)) {
goto L3;
}
/* Found slur is a turnoff, so new one is a turnon. Jump down to set bit */
goto L4;
}
/* L2: */
}
/* If here, this is turnon. */
L4:
isdat1[*nsdat] = bit_set(isdat1[*nsdat],11);
L3:
/* Now done with initial turnon- or turnoff-specifics. */
if (i_nint(&comslur_1.slurcurve) != 0 && bit_test(isdat1[*nsdat],11)) {
/* There's a default curvature tweak */
icurv1 = i_nint(&comslur_1.slurcurve) + 3;
if (icurv1 == 2) {
icurv1 = 1;
}
isdat3[*nsdat] = bit_set(isdat3[*nsdat],0);
i__1 = icurv1 + 32;
setbits_(&isdat3[*nsdat], &c__6, &c__2, &i__1);
}
/* Loop for rest of input */
L1:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("uld", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Force direction */
isdat1[*nsdat] = bit_set(isdat1[*nsdat],26);
if (*(unsigned char *)durq == 'u') {
isdat1[*nsdat] = bit_set(isdat1[*nsdat],27);
}
goto L1;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
++numint;
if (numint == 1) {
/* Vertical offset */
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
ivoff = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
ivoff = -ivoff;
}
} else if (numint == 2) {
/* Horizontal offset */
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
/* fnum is abs(hshift), must be 0 to 6.3 */
ihoff = fnum * 10 + .5f;
if (*(unsigned char *)durq == '-') {
ihoff = -ihoff;
}
/* Later will set bits to 1...127 to represent -6.3,...+6.3 */
} else {
/* Must be the 3rd signed integer, so it's a curve specification */
isdat3[*nsdat] = bit_set(isdat3[*nsdat],0);
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
icurv1 = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
icurv1 = -icurv1;
}
i__1 = icurv1 + 32;
setbits_(&isdat3[*nsdat], &c__6, &c__2, &i__1);
if (*(unsigned char *)dumq != ':') {
/* Back up the pointer and loop for more input */
--(*iccount);
} else {
/* Expect two single digits as parameters for curve */
isdat3[*nsdat] = bit_set(isdat3[*nsdat],1);
i__1 = *iccount;
i__2 = *(unsigned char *)&lineq[i__1] - 48;
setbits_(&isdat3[*nsdat], &c__3, &c__8, &i__2);
i__1 = *iccount + 1;
i__2 = *(unsigned char *)&lineq[i__1] - 48;
setbits_(&isdat3[*nsdat], &c__3, &c__11, &i__2);
*iccount += 2;
}
}
goto L1;
} else if (*(unsigned char *)durq == 't') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],3);
goto L1;
} else if (*(unsigned char *)durq == 'b') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],4);
goto L1;
} else if (*(unsigned char *)durq == 's') {
/* Endpoint tweaks for linebreak slurs. */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* Next is vertical offset */
/* Must be +|- */
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)durq == '-') {
fnum = -fnum;
}
i__1 = ilb12 << 4;
i__2 = i_nint(&fnum) + 32;
setbits_(&isdat4[*nsdat], &c__6, &i__1, &i__2);
if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) {
/* Also a horizontal offset */
++(*iccount);
readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1);
if (*(unsigned char *)dumq == '-') {
fnum = -fnum;
}
i__1 = (ilb12 << 4) + 6;
r__1 = fnum * 10;
i__2 = i_nint(&r__1) + 64;
setbits_(&isdat4[*nsdat], &c__7, &i__1, &i__2);
}
--(*iccount);
ilb12 = 1;
goto L1;
} else if (i_indx("fnhH", durq, (ftnlen)4, (ftnlen)1) > 0) {
/* Special ps slur curvatures. */
/* Translate to old \midslur args (1,4,5,6) */
icurv1 = i_indx("fnxhH", durq, (ftnlen)5, (ftnlen)1);
if (icurv1 == 5) {
/* check for 2nd H */
i__1 = *iccount;
if (s_cmp(lineq + i__1, "H", *iccount + 1 - i__1, (ftnlen)1) == 0)
{
++(*iccount);
icurv1 = 6;
}
}
isdat3[*nsdat] = bit_set(isdat3[*nsdat],0);
i__1 = icurv1 + 32;
setbits_(&isdat3[*nsdat], &c__6, &c__2, &i__1);
goto L1;
} else if (*(unsigned char *)durq == 'p') {
/* Local adjustment */
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
/* +|- */
getchar_(lineq, iccount, dumq, (ftnlen)128, (ftnlen)1);
/* 26 \sluradjust (p+s) */
/* 27 \nosluradjust (p-s) */
/* 28 \tieadjust (p+t) */
/* 29 \notieadjust (p-t) */
/* s|t */
if (*(unsigned char *)durq == '+') {
if (*(unsigned char *)dumq == 's') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],26);
} else {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],28);
}
} else {
if (*(unsigned char *)dumq == 's') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],27);
} else {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],29);
}
}
goto L1;
}
/* Record shifts */
i__1 = ivoff + 32;
setbits_(&isdat2[*nsdat], &c__6, &c__6, &i__1);
i__1 = ihoff + 64;
setbits_(&isdat2[*nsdat], &c__7, &c__12, &i__1);
/* Record chord flag, note level, notehead shift */
if (*notcrd) {
setbits_(&isdat2[*nsdat], &c__7, &c__19, nolev);
} else {
nolevc = igetbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__7, &
c__12);
setbits_(&isdat2[*nsdat], &c__7, &c__19, &nolevc);
isdat2[*nsdat] = bit_set(isdat2[*nsdat],0);
i__1 = igetbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__2, &
c__23);
setbits_(&isdat2[*nsdat], &c__2, &c__1, &i__1);
}
return 0;
} /* spsslur_ */
/* Subroutine */ int sslur_(char *lineq, integer *iccount, integer *iv,
integer *kv, integer *ip, integer *isdat1, integer *isdat2, integer *
isdat3, integer *nsdat, logical *notcrd, integer *nolev, char *
starter, ftnlen lineq_len, ftnlen starter_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), i_nint(real *), s_cmp(
char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer igetbits_(integer *, integer *, integer *);
static real fnum;
static char dumq[1], durq[1];
static integer ihoff, isdat, ivoff, icurv1, idcode, nolevc, numint;
extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen,
ftnlen), readnum_(char *, integer *, char *, real *, ftnlen,
ftnlen), setbits_(integer *, integer *, integer *, integer *);
/* Reads in slur data. Record all h/v-shifts for non-chords, user-specified */
/* ones for chords. */
/* 5/26/02 now only for non-postscript slurs, use spsslur() for postscript */
/* See subroutine doslur for bit values in isdat1,2,3 */
/* Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve */
/* Parameter adjustments */
--isdat3;
--isdat2;
--isdat1;
/* Function Body */
numint = 0;
ivoff = 0;
ihoff = 0;
++(*nsdat);
if (*(unsigned char *)starter == '{' || *(unsigned char *)starter == '}')
{
isdat2[*nsdat] = bit_set(isdat2[*nsdat],3);
}
setbits_(&isdat1[*nsdat], &c__5, &c__13, iv);
i__1 = *kv - 1;
setbits_(&isdat1[*nsdat], &c__1, &c__12, &i__1);
setbits_(&isdat1[*nsdat], &c__8, &c__3, ip);
isdat3[*nsdat] = 0;
/* Get id letter */
if (*(unsigned char *)&lineq[*iccount - 1] == 't') {
/* Old-style t-slur. Use special idcode = 1 */
idcode = 1;
} else {
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("uldtb+-hf ", durq, (ftnlen)10, (ftnlen)1) > 0) {
/* Null id */
idcode = 32;
--(*iccount);
} else if (*(unsigned char *)durq == 'H') {
/* Postscript slur, cannot use 'H' as code, must check for 2nd 'H' */
idcode = 32;
--(*iccount);
/* There may be another "H", but no need to deal with it yet */
} else {
/* Set explicit idcode */
idcode = *(unsigned char *)durq;
}
}
setbits_(&isdat1[*nsdat], &c__7, &c__19, &idcode);
/* Set start/stop: look thru list from end for same idcode,iv,kv */
for (isdat = *nsdat - 1; isdat >= 1; --isdat) {
if (idcode == igetbits_(&isdat1[isdat], &c__7, &c__19) && *iv ==
igetbits_(&isdat1[isdat], &c__5, &c__13) && *kv - 1 ==
igetbits_(&isdat1[isdat], &c__1, &c__12)) {
/* Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. */
if (bit_test(isdat1[isdat],11)) {
goto L3;
}
/* Found slur is a turnoff, so new one is a turnon. Jump down to set bit */
goto L4;
}
/* L2: */
}
/* If here, this is turnon. */
L4:
isdat1[*nsdat] = bit_set(isdat1[*nsdat],11);
L3:
/* Now done with initial turnon- or turnoff-specifics. Loop for rest of input */
L1:
getchar_(lineq, iccount, durq, (ftnlen)128, (ftnlen)1);
if (i_indx("uld", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Force direction */
isdat1[*nsdat] = bit_set(isdat1[*nsdat],26);
if (*(unsigned char *)durq == 'u') {
isdat1[*nsdat] = bit_set(isdat1[*nsdat],27);
}
goto L1;
} else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) {
++numint;
if (numint == 1) {
/* Vertical offset */
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
ivoff = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
ivoff = -ivoff;
}
} else if (numint == 2) {
/* Horizontal offset */
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
--(*iccount);
/* fnum is abs(hshift), must be 0 to 6.3 */
ihoff = fnum * 10 + .5f;
if (*(unsigned char *)durq == '-') {
ihoff = -ihoff;
}
/* Later will set bits to 1...127 to represent -6.3,...+6.3 */
} else {
/* Must be the 3rd signed integer, so it's a curve specification */
isdat3[*nsdat] = bit_set(isdat3[*nsdat],0);
++(*iccount);
readnum_(lineq, iccount, dumq, &fnum, (ftnlen)128, (ftnlen)1);
icurv1 = i_nint(&fnum);
if (*(unsigned char *)durq == '-') {
icurv1 = -icurv1;
}
i__1 = icurv1 + 32;
setbits_(&isdat3[*nsdat], &c__6, &c__2, &i__1);
if (*(unsigned char *)dumq != ':') {
/* Back up the pointer and loop for more input */
--(*iccount);
} else {
/* Expect two single digits as parameters for curve */
isdat3[*nsdat] = bit_set(isdat3[*nsdat],1);
i__1 = *iccount;
i__2 = *(unsigned char *)&lineq[i__1] - 48;
setbits_(&isdat3[*nsdat], &c__3, &c__8, &i__2);
i__1 = *iccount + 1;
i__2 = *(unsigned char *)&lineq[i__1] - 48;
setbits_(&isdat3[*nsdat], &c__3, &c__11, &i__2);
*iccount += 2;
}
}
goto L1;
} else if (*(unsigned char *)durq == 't') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],3);
goto L1;
} else if (*(unsigned char *)durq == 'b') {
isdat2[*nsdat] = bit_set(isdat2[*nsdat],4);
goto L1;
} else if (i_indx("fhH", durq, (ftnlen)3, (ftnlen)1) > 0) {
/* Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) */
icurv1 = i_indx("fhH", durq, (ftnlen)3, (ftnlen)1) + 2;
if (icurv1 == 3) {
icurv1 = 1;
} else if (icurv1 == 5) {
/* check for 2nd H */
i__1 = *iccount;
if (s_cmp(lineq + i__1, "H", *iccount + 1 - i__1, (ftnlen)1) == 0)
{
++(*iccount);
icurv1 = 6;
}
}
isdat3[*nsdat] = bit_set(isdat3[*nsdat],0);
/* Must change sign if downslur, but cannot do it now since we don't know */
/* slur direction for sure. */
i__1 = icurv1 + 32;
setbits_(&isdat3[*nsdat], &c__6, &c__2, &i__1);
goto L1;
}
/* Record shifts */
i__1 = ivoff + 32;
setbits_(&isdat2[*nsdat], &c__6, &c__6, &i__1);
i__1 = ihoff + 64;
setbits_(&isdat2[*nsdat], &c__7, &c__12, &i__1);
/* Record chord flag, note level, notehead shift */
if (*notcrd) {
setbits_(&isdat2[*nsdat], &c__7, &c__19, nolev);
} else {
nolevc = igetbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__7, &
c__12);
setbits_(&isdat2[*nsdat], &c__7, &c__19, &nolevc);
isdat2[*nsdat] = bit_set(isdat2[*nsdat],0);
i__1 = igetbits_(&comtrill_1.icrdat[comtrill_1.ncrd - 1], &c__2, &
c__23);
setbits_(&isdat2[*nsdat], &c__2, &c__1, &i__1);
}
return 0;
} /* sslur_ */
/* Subroutine */ int stop1_(void)
{
extern /* Subroutine */ int exit_(integer *);
exit_(&c__1);
return 0;
} /* stop1_ */
/* Subroutine */ int topfile_(char *basenameq, integer *lbase, integer *nv,
char *clefq, integer *noinst, integer *musicsize, real *xinstf1,
integer *mtrnmp, integer *mtrdnp, logical *vshrink, real *fbar,
logical *fontslur, ftnlen basenameq_len, ftnlen clefq_len)
{
/* System generated locals */
address a__1[3], a__2[2], a__3[4], a__4[6], a__5[2], a__6[10], a__7[20],
a__8[12], a__9[8];
integer i__1[3], i__2[2], i__3[4], i__4[6], i__5, i__6[2], i__7, i__8,
i__9[10], i__10[20], i__11[12], i__12[8];
real r__1;
char ch__1[1], ch__2[50], ch__3[15], ch__4[10], ch__5[39], ch__6[14],
ch__7[17], ch__8[16], ch__9[32], ch__10[8], ch__11[12], ch__12[9],
ch__13[13], ch__14[11], ch__15[21], ch__16[7], ch__17[6], ch__18[
30], ch__19[19], ch__20[1], ch__21[2], ch__22[33], ch__23[25],
ch__24[81], ch__25[82], ch__26[18], ch__27[57], ch__28[44],
ch__29[62], ch__30[54], ch__31[86], ch__32[41], ch__33[47];
cilist ci__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), e_wsfi(void), i_nint(real *);
double r_lg10(real *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer k, iv;
static char sq[1];
static integer ipi;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static char fmtq[24];
extern /* Subroutine */ int writesetsign_(integer *, integer *, integer *,
logical *);
static char fbarq[5];
static integer lname, lfmtq, iinst;
extern integer numclef_(char *, ftnlen);
extern /* Subroutine */ int wgmeter_(integer *, integer *);
static integer nstaves;
/* Fortran I/O blocks */
static cilist io___1668 = { 0, 11, 0, "(a)", 0 };
static cilist io___1669 = { 0, 11, 0, "(a)", 0 };
static cilist io___1670 = { 0, 11, 0, "(a)", 0 };
static cilist io___1671 = { 0, 11, 0, "(a)", 0 };
static cilist io___1672 = { 0, 11, 0, "(a)", 0 };
static cilist io___1673 = { 0, 11, 0, "(a)", 0 };
static cilist io___1674 = { 0, 11, 0, "(a)", 0 };
static cilist io___1675 = { 0, 11, 0, "(a)", 0 };
static cilist io___1676 = { 0, 11, 0, "(a)", 0 };
static cilist io___1677 = { 0, 11, 0, "(a)", 0 };
static cilist io___1678 = { 0, 11, 0, "(a)", 0 };
static cilist io___1679 = { 0, 11, 0, "(a)", 0 };
static cilist io___1680 = { 0, 11, 0, "(a)", 0 };
static cilist io___1681 = { 0, 11, 0, "(a)", 0 };
static cilist io___1682 = { 0, 11, 0, "(a)", 0 };
static cilist io___1684 = { 0, 11, 0, "(a8,i1,a)", 0 };
static cilist io___1685 = { 0, 11, 0, "(a9,i2,a)", 0 };
static cilist io___1686 = { 0, 11, 0, "(a8,i1,a)", 0 };
static cilist io___1687 = { 0, 11, 0, "(a9,i2,a)", 0 };
static icilist io___1689 = { 0, fbarq, 0, "(f5.3)", 5, 1 };
static cilist io___1690 = { 0, 11, 0, "(a)", 0 };
static cilist io___1691 = { 0, 11, 0, "(a)", 0 };
static cilist io___1692 = { 0, 11, 0, "(a7,i3,a2)", 0 };
static cilist io___1693 = { 0, 11, 0, "(a8,i3,a2)", 0 };
static cilist io___1694 = { 0, 11, 0, "(a8,i2,a2)", 0 };
static cilist io___1695 = { 0, 11, 0, "(a8,i1,a2)", 0 };
static cilist io___1696 = { 0, 11, 0, "(a8,i2,a2)", 0 };
static cilist io___1697 = { 0, 11, 0, "(a8,i3,a2)", 0 };
static cilist io___1698 = { 0, 11, 0, "(a8,i2,a2)", 0 };
static cilist io___1699 = { 0, 11, 0, "(a8,i1,a2)", 0 };
static cilist io___1700 = { 0, 11, 0, "(a8,i2,a2)", 0 };
static cilist io___1701 = { 0, 11, 0, "(a)", 0 };
static cilist io___1702 = { 0, 11, 0, "(a19,i1,a1)", 0 };
static cilist io___1703 = { 0, 11, 0, "(a19,i2,a1)", 0 };
static cilist io___1706 = { 0, 11, 0, "(a)", 0 };
static cilist io___1707 = { 0, 11, 0, "(a11,i2,a)", 0 };
static cilist io___1711 = { 0, 11, 0, "(a)", 0 };
static cilist io___1712 = { 0, 11, 0, "(a9,i2,a)", 0 };
static cilist io___1714 = { 0, 11, 0, "(a8,i1,a)", 0 };
static cilist io___1715 = { 0, 11, 0, "(a9,i2,a)", 0 };
static cilist io___1716 = { 0, 11, 0, "(a18,i2,a2)", 0 };
static cilist io___1718 = { 0, 11, 0, "(a11,i1,a2)", 0 };
static cilist io___1719 = { 0, 11, 0, "(a11,i2,a2)", 0 };
static cilist io___1720 = { 0, 11, 0, "(a11,i3,a2)", 0 };
static cilist io___1721 = { 0, 11, 0, "(a)", 0 };
static cilist io___1722 = { 0, 11, 0, fmtq, 0 };
static cilist io___1723 = { 0, 11, 0, "(a)", 0 };
static cilist io___1724 = { 0, 11, 0, "(a)", 0 };
static cilist io___1725 = { 0, 11, 0, "(a)", 0 };
static cilist io___1726 = { 0, 11, 0, "(a)", 0 };
static cilist io___1727 = { 0, 11, 0, "(a)", 0 };
static cilist io___1728 = { 0, 11, 0, "(a)", 0 };
/* Parameter adjustments */
--clefq;
/* Function Body */
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
*vshrink = *xinstf1 > 20.f && ! comnvst_1.novshrinktop;
if (*vshrink) {
comarp_1.xinsnow = 10.f;
} else {
comarp_1.xinsnow = *xinstf1;
}
if (! comlast_1.islast) {
return 0;
}
s_wsfe(&io___1668);
do_fio(&c__1, "%%%%%%%%%%%%%%%%%", (ftnlen)17);
e_wsfe();
s_wsfe(&io___1669);
do_fio(&c__1, "%", (ftnlen)1);
e_wsfe();
s_wsfe(&io___1670);
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "% ";
i__1[1] = *lbase, a__1[1] = basenameq;
i__1[2] = 4, a__1[2] = ".tex";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50);
do_fio(&c__1, ch__2, *lbase + 6);
e_wsfe();
s_wsfe(&io___1671);
do_fio(&c__1, "%", (ftnlen)1);
e_wsfe();
s_wsfe(&io___1672);
do_fio(&c__1, "%%%%%%%%%%%%%%%%", (ftnlen)16);
e_wsfe();
s_wsfe(&io___1673);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 14, a__2[1] = "input musixtex";
s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15);
do_fio(&c__1, ch__3, (ftnlen)15);
e_wsfe();
s_wsfe(&io___1674);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 9, a__2[1] = "input pmx";
s_cat(ch__4, a__2, i__2, &c__2, (ftnlen)10);
do_fio(&c__1, ch__4, (ftnlen)10);
e_wsfe();
/* write(11,'(a)')sq//'input musixmad' */
/* write(11,'(a)')sq//'input musixxad' */
s_wsfe(&io___1675);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 15, a__3[1] = "setmaxslurs{24}";
i__3[2] = 1, a__3[2] = sq;
i__3[3] = 22, a__3[3] = "setmaxinstruments{24}%";
s_cat(ch__5, a__3, i__3, &c__4, (ftnlen)39);
do_fio(&c__1, ch__5, (ftnlen)39);
e_wsfe();
if (! (*fontslur)) {
s_wsfe(&io___1676);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 13, a__2[1] = "input musixps";
s_cat(ch__6, a__2, i__2, &c__2, (ftnlen)14);
do_fio(&c__1, ch__6, (ftnlen)14);
e_wsfe();
}
/* Need to input musixmad to permit more slurs. */
if (*musicsize == 20) {
s_wsfe(&io___1677);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 16, a__2[1] = "normalmusicsize%";
s_cat(ch__7, a__2, i__2, &c__2, (ftnlen)17);
do_fio(&c__1, ch__7, (ftnlen)17);
e_wsfe();
} else if (*musicsize == 16) {
s_wsfe(&io___1678);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 15, a__2[1] = "smallmusicsize%";
s_cat(ch__8, a__2, i__2, &c__2, (ftnlen)16);
do_fio(&c__1, ch__8, (ftnlen)16);
e_wsfe();
} else if (*musicsize == 24) {
s_wsfe(&io___1679);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 15, a__2[1] = "largemusicsize%";
s_cat(ch__8, a__2, i__2, &c__2, (ftnlen)16);
do_fio(&c__1, ch__8, (ftnlen)16);
e_wsfe();
s_wsfe(&io___1680);
/* Writing concatenation */
i__4[0] = 1, a__4[0] = sq;
i__4[1] = 3, a__4[1] = "def";
i__4[2] = 1, a__4[2] = sq;
i__4[3] = 10, a__4[3] = "meterfont{";
i__4[4] = 1, a__4[4] = sq;
i__4[5] = 16, a__4[5] = "meterlargefont}%";
s_cat(ch__9, a__4, i__4, &c__6, (ftnlen)32);
do_fio(&c__1, ch__9, (ftnlen)32);
e_wsfe();
} else if (*musicsize == 29) {
s_wsfe(&io___1681);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 15, a__2[1] = "Largemusicsize%";
s_cat(ch__8, a__2, i__2, &c__2, (ftnlen)16);
do_fio(&c__1, ch__8, (ftnlen)16);
e_wsfe();
s_wsfe(&io___1682);
/* Writing concatenation */
i__4[0] = 1, a__4[0] = sq;
i__4[1] = 3, a__4[1] = "def";
i__4[2] = 1, a__4[2] = sq;
i__4[3] = 10, a__4[3] = "meterfont{";
i__4[4] = 1, a__4[4] = sq;
i__4[5] = 16, a__4[5] = "meterLargefont}%";
s_cat(ch__9, a__4, i__4, &c__6, (ftnlen)32);
do_fio(&c__1, ch__9, (ftnlen)32);
e_wsfe();
}
/* Set sizes. Have sizes per staff in isize(.) and noinst per staff in */
/* nsperi(.) */
/* 130324 */
/* iiv = 1 */
i__5 = *noinst;
for (iinst = 1; iinst <= i__5; ++iinst) {
/* if (isize(iiv) .eq. 1) then */
if (comsize_1.isize[iinst - 1] == 1) {
if (iinst <= 9) {
s_wsfe(&io___1684);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "setsize";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__6[0] = 1, a__5[0] = sq;
i__6[1] = 11, a__5[1] = "smallvalue%";
s_cat(ch__11, a__5, i__6, &c__2, (ftnlen)12);
do_fio(&c__1, ch__11, (ftnlen)12);
e_wsfe();
} else {
s_wsfe(&io___1685);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 8, a__2[1] = "setsize{";
s_cat(ch__12, a__2, i__2, &c__2, (ftnlen)9);
do_fio(&c__1, ch__12, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__1[0] = 1, a__1[0] = "}";
i__1[1] = 1, a__1[1] = sq;
i__1[2] = 11, a__1[2] = "smallvalue%";
s_cat(ch__13, a__1, i__1, &c__3, (ftnlen)13);
do_fio(&c__1, ch__13, (ftnlen)13);
e_wsfe();
}
/* else if (isize(iiv) .eq. 2) then */
} else if (comsize_1.isize[iinst - 1] == 2) {
if (iinst <= 9) {
s_wsfe(&io___1686);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "setsize";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__6[0] = 1, a__5[0] = sq;
i__6[1] = 10, a__5[1] = "tinyvalue%";
s_cat(ch__14, a__5, i__6, &c__2, (ftnlen)11);
do_fio(&c__1, ch__14, (ftnlen)11);
e_wsfe();
} else {
s_wsfe(&io___1687);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 8, a__2[1] = "setsize{";
s_cat(ch__12, a__2, i__2, &c__2, (ftnlen)9);
do_fio(&c__1, ch__12, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__1[0] = 1, a__1[0] = "}";
i__1[1] = 1, a__1[1] = sq;
i__1[2] = 10, a__1[2] = "tinyvalue%";
s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)12);
do_fio(&c__1, ch__11, (ftnlen)12);
e_wsfe();
}
}
/* iiv = iiv+nsperi(iinst) */
/* L5: */
}
s_wsfi(&io___1689);
do_fio(&c__1, (char *)&(*fbar), (ftnlen)sizeof(real));
e_wsfi();
s_wsfe(&io___1690);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 13, a__2[1] = "nopagenumbers";
s_cat(ch__6, a__2, i__2, &c__2, (ftnlen)14);
do_fio(&c__1, ch__6, (ftnlen)14);
e_wsfe();
s_wsfe(&io___1691);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 14, a__3[1] = "tracingstats=2";
i__3[2] = 1, a__3[2] = sq;
i__3[3] = 5, a__3[3] = "relax";
s_cat(ch__15, a__3, i__3, &c__4, (ftnlen)21);
do_fio(&c__1, ch__15, (ftnlen)21);
e_wsfe();
s_wsfe(&io___1692);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 6, a__2[1] = "hsize=";
s_cat(ch__16, a__2, i__2, &c__2, (ftnlen)7);
do_fio(&c__1, ch__16, (ftnlen)7);
i__5 = i_nint(&comtop_1.widthpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = 11;
/* Writing concatenation */
i__1[0] = 5, a__1[0] = "(a6,i";
r__1 = comtop_1.height + .1f;
i__5 = (integer) r_lg10(&r__1) + 49;
chax_(ch__1, (ftnlen)1, &i__5);
i__1[1] = 1, a__1[1] = ch__1;
i__1[2] = 4, a__1[2] = ",a2)";
ci__1.cifmt = (s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)10), ch__4);
s_wsfe(&ci__1);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 5, a__2[1] = "vsize";
s_cat(ch__17, a__2, i__2, &c__2, (ftnlen)6);
do_fio(&c__1, ch__17, (ftnlen)6);
i__7 = (integer) (comtop_1.height + .1f);
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
if (dabs(comtop_1.hoffpt) > .1f) {
if (comtop_1.hoffpt <= -10.f) {
s_wsfe(&io___1693);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "hoffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.hoffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else if (comtop_1.hoffpt < 0.f) {
s_wsfe(&io___1694);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "hoffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.hoffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else if (comtop_1.hoffpt < 10.f) {
s_wsfe(&io___1695);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "hoffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.hoffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else {
s_wsfe(&io___1696);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "hoffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.hoffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
}
if (dabs(comtop_1.voffpt) > .1f) {
if (comtop_1.voffpt <= -10.f) {
s_wsfe(&io___1697);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "voffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.voffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else if (comtop_1.voffpt < 0.f) {
s_wsfe(&io___1698);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "voffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.voffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else if (comtop_1.voffpt < 10.f) {
s_wsfe(&io___1699);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "voffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.voffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else {
s_wsfe(&io___1700);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "voffset";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
i__5 = i_nint(&comtop_1.voffpt);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
}
/* The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if */
/* 3 sharps and treble clef, to avoid vertical clash with top space g# */
if (comtop_1.isig == 3 && *(unsigned char *)&clefq[*nv] == 't') {
s_wsfe(&io___1701);
/* Writing concatenation */
i__4[0] = 1, a__4[0] = sq;
i__4[1] = 3, a__4[1] = "def";
i__4[2] = 1, a__4[2] = sq;
i__4[3] = 14, a__4[3] = "raisebarno{4.5";
i__4[4] = 1, a__4[4] = sq;
i__4[5] = 10, a__4[5] = "internote}";
s_cat(ch__18, a__4, i__4, &c__6, (ftnlen)30);
do_fio(&c__1, ch__18, (ftnlen)30);
e_wsfe();
}
if (*noinst < 10) {
s_wsfe(&io___1702);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 3, a__3[1] = "def";
i__3[2] = 1, a__3[2] = sq;
i__3[3] = 14, a__3[3] = "nbinstruments{";
s_cat(ch__19, a__3, i__3, &c__4, (ftnlen)19);
do_fio(&c__1, ch__19, (ftnlen)19);
do_fio(&c__1, (char *)&(*noinst), (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfe();
} else {
s_wsfe(&io___1703);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 3, a__3[1] = "def";
i__3[2] = 1, a__3[2] = sq;
i__3[3] = 14, a__3[3] = "nbinstruments{";
s_cat(ch__19, a__3, i__3, &c__4, (ftnlen)19);
do_fio(&c__1, ch__19, (ftnlen)19);
do_fio(&c__1, (char *)&(*noinst), (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfe();
}
iv = 0;
i__5 = *noinst;
for (iinst = 1; iinst <= i__5; ++iinst) {
nstaves = comnvi_1.nsperi[iinst - 1];
if (iinst < 10) {
s_wsfe(&io___1706);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 9, a__3[1] = "setstaffs";
i__7 = iinst + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__3[2] = 1, a__3[2] = ch__1;
i__8 = nstaves + 48;
chax_(ch__20, (ftnlen)1, &i__8);
i__3[3] = 1, a__3[3] = ch__20;
s_cat(ch__11, a__3, i__3, &c__4, (ftnlen)12);
do_fio(&c__1, ch__11, (ftnlen)12);
e_wsfe();
} else {
s_wsfe(&io___1707);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 10, a__2[1] = "setstaffs{";
s_cat(ch__14, a__2, i__2, &c__2, (ftnlen)11);
do_fio(&c__1, ch__14, (ftnlen)11);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__6[0] = 1, a__5[0] = "}";
i__7 = nstaves + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__6[1] = 1, a__5[1] = ch__1;
s_cat(ch__21, a__5, i__6, &c__2, (ftnlen)2);
do_fio(&c__1, ch__21, (ftnlen)2);
e_wsfe();
}
++iv;
if (nstaves == 1) {
i__7 = numclef_(clefq + iv, (ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__7);
s_copy(fmtq, ch__1, (ftnlen)24, (ftnlen)1);
lfmtq = 1;
} else {
/* Writing concatenation */
i__2[0] = 1, a__2[0] = "{";
i__7 = numclef_(clefq + iv, (ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__2[1] = 1, a__2[1] = ch__1;
s_cat(fmtq, a__2, i__2, &c__2, (ftnlen)24);
lfmtq = 2;
i__7 = nstaves;
for (k = 2; k <= i__7; ++k) {
++iv;
/* Writing concatenation */
i__2[0] = lfmtq, a__2[0] = fmtq;
i__8 = numclef_(clefq + iv, (ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__8);
i__2[1] = 1, a__2[1] = ch__1;
s_cat(fmtq, a__2, i__2, &c__2, (ftnlen)24);
++lfmtq;
/* L2: */
}
/* Writing concatenation */
i__2[0] = lfmtq, a__2[0] = fmtq;
i__2[1] = 1, a__2[1] = "}";
s_cat(fmtq, a__2, i__2, &c__2, (ftnlen)24);
++lfmtq;
}
if (iinst < 10) {
s_wsfe(&io___1711);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 7, a__3[1] = "setclef";
i__7 = iinst + 48;
chax_(ch__1, (ftnlen)1, &i__7);
i__3[2] = 1, a__3[2] = ch__1;
i__3[3] = lfmtq, a__3[3] = fmtq;
s_cat(ch__22, a__3, i__3, &c__4, (ftnlen)33);
do_fio(&c__1, ch__22, lfmtq + 9);
e_wsfe();
} else {
s_wsfe(&io___1712);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 8, a__2[1] = "setclef{";
s_cat(ch__12, a__2, i__2, &c__2, (ftnlen)9);
do_fio(&c__1, ch__12, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__6[0] = 1, a__5[0] = "}";
i__6[1] = lfmtq, a__5[1] = fmtq;
s_cat(ch__23, a__5, i__6, &c__2, (ftnlen)25);
do_fio(&c__1, ch__23, lfmtq + 1);
e_wsfe();
}
for (lname = 79; lname >= 2; --lname) {
if (*(unsigned char *)&comtop_1.inameq[(iinst - 1) * 79 + (lname
- 1)] != ' ') {
goto L4;
}
/* L3: */
}
L4:
comtop_1.lnam[iinst - 1] = lname;
if (iinst < 10) {
s_wsfe(&io___1714);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 7, a__2[1] = "setname";
s_cat(ch__10, a__2, i__2, &c__2, (ftnlen)8);
do_fio(&c__1, ch__10, (ftnlen)8);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__1[0] = 1, a__1[0] = "{";
i__1[1] = lname, a__1[1] = comtop_1.inameq + (iinst - 1) * 79;
i__1[2] = 1, a__1[2] = "}";
s_cat(ch__24, a__1, i__1, &c__3, (ftnlen)81);
do_fio(&c__1, ch__24, lname + 2);
e_wsfe();
} else {
s_wsfe(&io___1715);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 8, a__2[1] = "setname{";
s_cat(ch__12, a__2, i__2, &c__2, (ftnlen)9);
do_fio(&c__1, ch__12, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
/* Writing concatenation */
i__1[0] = 2, a__1[0] = "}{";
i__1[1] = lname, a__1[1] = comtop_1.inameq + (iinst - 1) * 79;
i__1[2] = 1, a__1[2] = "}";
s_cat(ch__25, a__1, i__1, &c__3, (ftnlen)82);
do_fio(&c__1, ch__25, lname + 3);
e_wsfe();
}
/* L1: */
}
s_wsfe(&io___1716);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 17, a__2[1] = "generalsignature{";
s_cat(ch__26, a__2, i__2, &c__2, (ftnlen)18);
do_fio(&c__1, ch__26, (ftnlen)18);
do_fio(&c__1, (char *)&comtop_1.isig, (ftnlen)sizeof(integer));
do_fio(&c__1, "}%", (ftnlen)2);
e_wsfe();
if (cominsttrans_1.earlytranson) {
writesetsign_(&cominsttrans_1.ninsttrans, cominsttrans_1.iinsttrans,
cominsttrans_1.itranskey, &cominsttrans_1.earlytranson);
}
wgmeter_(mtrnmp, mtrdnp);
r__1 = comtop_1.fracindent * comtop_1.widthpt;
ipi = i_nint(&r__1);
if (ipi < 10) {
s_wsfe(&io___1718);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 10, a__2[1] = "parindent ";
s_cat(ch__14, a__2, i__2, &c__2, (ftnlen)11);
do_fio(&c__1, ch__14, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else if (ipi < 100) {
s_wsfe(&io___1719);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 10, a__2[1] = "parindent ";
s_cat(ch__14, a__2, i__2, &c__2, (ftnlen)11);
do_fio(&c__1, ch__14, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
} else {
s_wsfe(&io___1720);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 10, a__2[1] = "parindent ";
s_cat(ch__14, a__2, i__2, &c__2, (ftnlen)11);
do_fio(&c__1, ch__14, (ftnlen)11);
do_fio(&c__1, (char *)&ipi, (ftnlen)sizeof(integer));
do_fio(&c__1, "pt", (ftnlen)2);
e_wsfe();
}
s_wsfe(&io___1721);
/* Writing concatenation */
i__9[0] = 1, a__6[0] = sq;
i__9[1] = 11, a__6[1] = "elemskip1pt";
i__9[2] = 1, a__6[2] = sq;
i__9[3] = 13, a__6[3] = "afterruleskip";
i__9[4] = 5, a__6[4] = fbarq;
i__9[5] = 2, a__6[5] = "pt";
i__9[6] = 1, a__6[6] = sq;
i__9[7] = 17, a__6[7] = "beforeruleskip0pt";
i__9[8] = 1, a__6[8] = sq;
i__9[9] = 5, a__6[9] = "relax";
s_cat(ch__27, a__6, i__9, &c__10, (ftnlen)57);
do_fio(&c__1, ch__27, (ftnlen)57);
e_wsfe();
if (! (*vshrink)) {
if (*xinstf1 < 9.95f) {
s_copy(fmtq, "(a,f3.1,a)", (ftnlen)24, (ftnlen)10);
} else {
s_copy(fmtq, "(a,f4.1,a)", (ftnlen)24, (ftnlen)10);
}
s_wsfe(&io___1722);
/* Writing concatenation */
i__4[0] = 1, a__4[0] = sq;
i__4[1] = 15, a__4[1] = "stafftopmarg0pt";
i__4[2] = 1, a__4[2] = sq;
i__4[3] = 15, a__4[3] = "staffbotmarg0pt";
i__4[4] = 1, a__4[4] = sq;
i__4[5] = 11, a__4[5] = "interstaff{";
s_cat(ch__28, a__4, i__4, &c__6, (ftnlen)44);
do_fio(&c__1, ch__28, (ftnlen)44);
do_fio(&c__1, (char *)&(*xinstf1), (ftnlen)sizeof(real));
/* Writing concatenation */
i__1[0] = 1, a__1[0] = "}";
i__1[1] = 1, a__1[1] = sq;
i__1[2] = 5, a__1[2] = "relax";
s_cat(ch__16, a__1, i__1, &c__3, (ftnlen)7);
do_fio(&c__1, ch__16, (ftnlen)7);
e_wsfe();
} else {
s_wsfe(&io___1723);
/* Writing concatenation */
i__9[0] = 1, a__6[0] = sq;
i__9[1] = 15, a__6[1] = "stafftopmarg0pt";
i__9[2] = 1, a__6[2] = sq;
i__9[3] = 13, a__6[3] = "staffbotmarg5";
i__9[4] = 1, a__6[4] = sq;
i__9[5] = 10, a__6[5] = "Interligne";
i__9[6] = 1, a__6[6] = sq;
i__9[7] = 14, a__6[7] = "interstaff{10}";
i__9[8] = 1, a__6[8] = sq;
i__9[9] = 5, a__6[9] = "relax";
s_cat(ch__29, a__6, i__9, &c__10, (ftnlen)62);
do_fio(&c__1, ch__29, (ftnlen)62);
e_wsfe();
}
if (*nv == 1) {
s_wsfe(&io___1724);
/* Writing concatenation */
i__2[0] = 1, a__2[0] = sq;
i__2[1] = 11, a__2[1] = "nostartrule";
s_cat(ch__11, a__2, i__2, &c__2, (ftnlen)12);
do_fio(&c__1, ch__11, (ftnlen)12);
e_wsfe();
}
s_wsfe(&io___1725);
/* Writing concatenation */
i__3[0] = 1, a__3[0] = sq;
i__3[1] = 8, a__3[1] = "readmod{";
i__3[2] = *lbase, a__3[2] = basenameq;
i__3[3] = 1, a__3[3] = "}";
s_cat(ch__30, a__3, i__3, &c__4, (ftnlen)54);
do_fio(&c__1, ch__30, *lbase + 10);
e_wsfe();
if (comnvst_1.cstuplet) {
s_wsfe(&io___1726);
/* Writing concatenation */
i__10[0] = 1, a__7[0] = sq;
i__10[1] = 12, a__7[1] = "input tuplet";
i__10[2] = 1, a__7[2] = sq;
i__10[3] = 3, a__7[3] = "def";
i__10[4] = 1, a__7[4] = sq;
i__10[5] = 12, a__7[5] = "xnumt#1#2#3{";
i__10[6] = 1, a__7[6] = sq;
i__10[7] = 16, a__7[7] = "zcharnote{#2}{~}";
i__10[8] = 1, a__7[8] = sq;
i__10[9] = 3, a__7[9] = "def";
i__10[10] = 1, a__7[10] = sq;
i__10[11] = 10, a__7[11] = "tuplettxt{";
i__10[12] = 1, a__7[12] = sq;
i__10[13] = 9, a__7[13] = "smalltype";
i__10[14] = 1, a__7[14] = sq;
i__10[15] = 6, a__7[15] = "it{#3}";
i__10[16] = 1, a__7[16] = sq;
i__10[17] = 1, a__7[17] = "/";
i__10[18] = 1, a__7[18] = sq;
i__10[19] = 4, a__7[19] = "/}}%";
s_cat(ch__31, a__7, i__10, &c__20, (ftnlen)86);
do_fio(&c__1, ch__31, (ftnlen)86);
e_wsfe();
s_wsfe(&io___1727);
/* Writing concatenation */
i__11[0] = 1, a__8[0] = sq;
i__11[1] = 3, a__8[1] = "let";
i__11[2] = 1, a__8[2] = sq;
i__11[3] = 5, a__8[3] = "ovbkt";
i__11[4] = 1, a__8[4] = sq;
i__11[5] = 8, a__8[5] = "uptuplet";
i__11[6] = 1, a__8[6] = sq;
i__11[7] = 3, a__8[7] = "let";
i__11[8] = 1, a__8[8] = sq;
i__11[9] = 5, a__8[9] = "unbkt";
i__11[10] = 1, a__8[10] = sq;
i__11[11] = 11, a__8[11] = "downtuplet%";
s_cat(ch__32, a__8, i__11, &c__12, (ftnlen)41);
do_fio(&c__1, ch__32, (ftnlen)41);
e_wsfe();
}
s_wsfe(&io___1728);
/* Writing concatenation */
i__12[0] = 1, a__9[0] = sq;
i__12[1] = 11, a__9[1] = "startmuflex";
i__12[2] = 1, a__9[2] = sq;
i__12[3] = 10, a__9[3] = "startpiece";
i__12[4] = 1, a__9[4] = sq;
i__12[5] = 8, a__9[5] = "addspace";
i__12[6] = 1, a__9[6] = sq;
i__12[7] = 14, a__9[7] = "afterruleskip%";
s_cat(ch__33, a__9, i__12, &c__8, (ftnlen)47);
do_fio(&c__1, ch__33, (ftnlen)47);
e_wsfe();
return 0;
} /* topfile_ */
/* Character */ VOID udfq_(char *ret_val, ftnlen ret_val_len, integer *nolev,
integer *ncm)
{
static integer ntest;
/* Slur directions */
ntest = *nolev - *ncm;
if (ntest < 0 || ntest == 0 && combc_1.bcspec && *ncm == 23) {
*(unsigned char *)ret_val = 'd';
} else {
*(unsigned char *)ret_val = 'u';
}
return ;
} /* udfq_ */
/* Character */ VOID udqq_(char *ret_val, ftnlen ret_val_len, integer *nole,
integer *ncm, integer *isl, integer *nvmx, integer *ivx, integer *nv)
{
/* System generated locals */
real r__1;
char ch__2[1];
/* Local variables */
extern /* Character */ VOID ulfq_(char *, ftnlen, real *, integer *);
static char udqqq[1];
/* Stem direction for single notes */
if (bit_test(*isl,30)) {
/* Absolute override */
if (bit_test(*isl,17)) {
*(unsigned char *)udqqq = 'u';
} else {
*(unsigned char *)udqqq = 'l';
}
} else if (*nvmx == 1) {
/* Single voice per staff, default */
r__1 = *nole * 1.f;
ulfq_(ch__2, (ftnlen)1, &r__1, ncm);
*(unsigned char *)udqqq = *(unsigned char *)&ch__2[0];
} else {
/* Multi-voice per staff, 1st is lower, 2nd upper */
if (*ivx <= *nv) {
*(unsigned char *)udqqq = 'l';
} else {
*(unsigned char *)udqqq = 'u';
}
}
*(unsigned char *)ret_val = *(unsigned char *)udqqq;
return ;
} /* udqq_ */
/* Character */ VOID ulfq_(char *ret_val, ftnlen ret_val_len, real *xnolev,
integer *ncm)
{
static real test;
/* Stem directions */
test = *xnolev - *ncm;
if (test < -.001f || test < .001f && combc_1.bcspec && *ncm == 23) {
*(unsigned char *)ret_val = 'u';
} else {
*(unsigned char *)ret_val = 'l';
}
return ;
} /* ulfq_ */
/* Character */ VOID upcaseq_(char *ret_val, ftnlen ret_val_len, char *chq,
ftnlen chq_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2];
char ch__2[1], ch__3[53];
/* Builtin functions */
integer s_wsle(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen), e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
/* Fortran I/O blocks */
static cilist io___1732 = { 0, 6, 0, 0, 0 };
if (*(unsigned char *)chq >= 61 && *(unsigned char *)chq < 122) {
i__1 = *(unsigned char *)chq - 32;
chax_(ch__2, (ftnlen)1, &i__1);
*(unsigned char *)ret_val = *(unsigned char *)&ch__2[0];
} else {
*(unsigned char *)ret_val = *(unsigned char *)chq;
s_wsle(&io___1732);
/* Writing concatenation */
i__2[0] = 52, a__1[0] = "Warning, upcaseq was called with improper a"
"rgument: ";
i__2[1] = 1, a__1[1] = chq;
s_cat(ch__3, a__1, i__2, &c__2, (ftnlen)53);
do_lio(&c__9, &c__1, ch__3, (ftnlen)53);
e_wsle();
s_stop("", (ftnlen)0);
}
return ;
} /* upcaseq_ */
/* Subroutine */ int wgmeter_(integer *mtrnmp, integer *mtrdnp)
{
/* System generated locals */
address a__1[4];
integer i__1[4], i__2;
char ch__1[1], ch__2[25], ch__3[26], ch__4[21], ch__5[24];
/* Builtin functions */
integer s_wsfe(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static char sq[1];
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
/* Fortran I/O blocks */
static cilist io___1734 = { 0, 11, 0, "(a25,i1,a2,i1,a3)", 0 };
static cilist io___1735 = { 0, 11, 0, "(a25,i1,a2,i2,a3)", 0 };
static cilist io___1736 = { 0, 11, 0, "(a25,i2,a2,i1,a3)", 0 };
static cilist io___1737 = { 0, 11, 0, "(a25,i2,a2,i2,a3)", 0 };
static cilist io___1738 = { 0, 11, 0, "(a26,i1,a2,i1,a3)", 0 };
static cilist io___1739 = { 0, 11, 0, "(a21,i1,a2)", 0 };
static cilist io___1740 = { 0, 11, 0, "(a)", 0 };
static cilist io___1741 = { 0, 11, 0, "(a)", 0 };
static cilist io___1742 = { 0, 11, 0, "(a)", 0 };
/* Writes meter stuff to file 11, so only called if islast=.true. */
if (*mtrdnp == 0) {
return 0;
}
chax_(ch__1, (ftnlen)1, &c__92);
*(unsigned char *)sq = *(unsigned char *)&ch__1[0];
if (*mtrnmp > 0 && *mtrnmp <= 9) {
if (*mtrdnp < 10) {
s_wsfe(&io___1734);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "meterfrac{";
s_cat(ch__2, a__1, i__1, &c__4, (ftnlen)25);
do_fio(&c__1, ch__2, (ftnlen)25);
do_fio(&c__1, (char *)&(*mtrnmp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}}%", (ftnlen)3);
e_wsfe();
} else {
s_wsfe(&io___1735);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "meterfrac{";
s_cat(ch__2, a__1, i__1, &c__4, (ftnlen)25);
do_fio(&c__1, ch__2, (ftnlen)25);
do_fio(&c__1, (char *)&(*mtrnmp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}}%", (ftnlen)3);
e_wsfe();
}
} else if (*mtrnmp >= 10) {
if (*mtrdnp < 10) {
s_wsfe(&io___1736);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "meterfrac{";
s_cat(ch__2, a__1, i__1, &c__4, (ftnlen)25);
do_fio(&c__1, ch__2, (ftnlen)25);
do_fio(&c__1, (char *)&(*mtrnmp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}}%", (ftnlen)3);
e_wsfe();
} else {
s_wsfe(&io___1737);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "meterfrac{";
s_cat(ch__2, a__1, i__1, &c__4, (ftnlen)25);
do_fio(&c__1, ch__2, (ftnlen)25);
do_fio(&c__1, (char *)&(*mtrnmp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}}%", (ftnlen)3);
e_wsfe();
}
} else if (*mtrnmp < 0) {
s_wsfe(&io___1738);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 11, a__1[3] = "meterfracS{";
s_cat(ch__3, a__1, i__1, &c__4, (ftnlen)26);
do_fio(&c__1, ch__3, (ftnlen)26);
i__2 = -(*mtrnmp);
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, "}{", (ftnlen)2);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}}%", (ftnlen)3);
e_wsfe();
} else if (*mtrdnp <= 4) {
s_wsfe(&io___1739);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 13, a__1[1] = "generalmeter{";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 6, a__1[3] = "meterN";
s_cat(ch__4, a__1, i__1, &c__4, (ftnlen)21);
do_fio(&c__1, ch__4, (ftnlen)21);
do_fio(&c__1, (char *)&(*mtrdnp), (ftnlen)sizeof(integer));
do_fio(&c__1, "}%", (ftnlen)2);
e_wsfe();
} else if (*mtrdnp == 5) {
s_wsfe(&io___1740);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 12, a__1[1] = "generalmeter";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "allabreve%";
s_cat(ch__5, a__1, i__1, &c__4, (ftnlen)24);
do_fio(&c__1, ch__5, (ftnlen)24);
e_wsfe();
} else if (*mtrdnp == 6) {
s_wsfe(&io___1741);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 12, a__1[1] = "generalmeter";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 7, a__1[3] = "meterC%";
s_cat(ch__4, a__1, i__1, &c__4, (ftnlen)21);
do_fio(&c__1, ch__4, (ftnlen)21);
e_wsfe();
} else if (*mtrdnp == 7) {
s_wsfe(&io___1742);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = sq;
i__1[1] = 12, a__1[1] = "generalmeter";
i__1[2] = 1, a__1[2] = sq;
i__1[3] = 10, a__1[3] = "meterIIIS%";
s_cat(ch__5, a__1, i__1, &c__4, (ftnlen)24);
do_fio(&c__1, ch__5, (ftnlen)24);
e_wsfe();
}
return 0;
} /* wgmeter_ */
/* Subroutine */ int writemidi_(char *jobname, integer *ljob, ftnlen
jobname_len)
{
/* Initialized data */
static shortint icmm[16] = { 0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16 };
/* System generated locals */
address a__1[4], a__2[7], a__3[3], a__4[2], a__5[12];
integer i__1[4], i__2, i__3[7], i__4[3], i__5[2], i__6, i__7[12], i__8,
i__9, i__10, i__11, i__12;
char ch__1[14], ch__2[1], ch__3[12], ch__4[1], ch__5[1], ch__6[46], ch__7[
27], ch__8[29], ch__9[15], ch__10[1], ch__11[4], ch__12[81],
ch__13[25];
cllist cl__1;
/* Builtin functions */
integer s_wsfe(cilist *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_fio(integer *, char *, ftnlen), e_wsfe(void), lbit_shift(
integer, integer), s_wsfi(icilist *), e_wsfi(void), f_clos(cllist
*);
/* Local variables */
static integer i__, kv, ib0, ib1, icm;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer isec, mend, ndata, ibyte;
static char byteq[1*4], instq[10], tempoq[10];
extern /* Subroutine */ int printl_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___1744 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1745 = { 0, 52, 0, "(a6,10Z4)", 0 };
static cilist io___1750 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1751 = { 0, 52, 0, "(a6,8z4)", 0 };
static cilist io___1752 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1753 = { 0, 52, 0, "(a)", 0 };
static cilist io___1754 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1755 = { 0, 52, 0, "(a)", 0 };
static cilist io___1758 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1759 = { 0, 52, 0, "(z4)", 0 };
static cilist io___1760 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1761 = { 0, 52, 0, "(4z4)", 0 };
static cilist io___1766 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1767 = { 0, 52, 0, "(a4,z2,a7,11z4)", 0 };
static cilist io___1768 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1769 = { 0, 52, 0, "(4z4)", 0 };
static cilist io___1770 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1771 = { 0, 52, 0, "(a)", 0 };
static icilist io___1773 = { 0, tempoq, 0, "(i2)", 10, 1 };
static icilist io___1775 = { 0, instq, 0, "(i3)", 10, 1 };
static cilist io___1776 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1777 = { 0, 52, 0, "(z4)", 0 };
static cilist io___1778 = { 0, 51, 0, "(a,$)", 0 };
static cilist io___1779 = { 0, 52, 0, "(4z4)", 0 };
static cilist io___1780 = { 0, 6, 0, "(1x,a12,(10i6))", 0 };
static cilist io___1781 = { 0, 15, 0, "(1x,a12,(10i6))", 0 };
/* Used to be icmm(0:nm); did midi fail when nv>16? */
/* These are not consecutive because channel 9 is reserved for percussion. */
/* Write Header */
s_wsfe(&io___1744);
/* Writing concatenation */
i__1[0] = 11, a__1[0] = "MThd\000\000\000\006\000\001\000";
*(unsigned char *)&ch__2[0] = commidi_1.numchan + 1;
i__1[1] = 1, a__1[1] = ch__2;
i__1[2] = 1, a__1[2] = "\000";
i__1[3] = 1, a__1[3] = "\360";
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)14);
do_fio(&c__1, ch__1, (ftnlen)14);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1745);
do_fio(&c__1, "\"MThd\"", (ftnlen)6);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
i__2 = commidi_1.numchan + 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__240, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Write the "conductor" track, for keys, meter, and tempos */
/* Get the number of bytes in the conductor event stream */
ndata = commidi_1.imidi[commidi_1.numchan] + 1 - commmac_1.msecstrt[
commidi_1.numchan + commmac_1.nmidsec * 25 - 25];
i__2 = commmac_1.nmidsec - 1;
for (isec = 1; isec <= i__2; ++isec) {
ndata = ndata + 1 + commmac_1.msecend[commidi_1.numchan + isec * 25 -
25] - commmac_1.msecstrt[commidi_1.numchan + isec * 25 - 25];
/* L15: */
}
/* ib1 = (4+ljob+26+ndata+4)/256 */
/* ib0 = 4+ljob+26+ndata+4-256*ib1 */
ib1 = (*ljob + 31 + ndata + 4) / 256;
ib0 = *ljob + 31 + ndata + 4 - (ib1 << 8);
s_wsfe(&io___1750);
/* Writing concatenation */
i__3[0] = 6, a__2[0] = "MTrk\000\000";
*(unsigned char *)&ch__2[0] = ib1;
i__3[1] = 1, a__2[1] = ch__2;
*(unsigned char *)&ch__4[0] = ib0;
i__3[2] = 1, a__2[2] = ch__4;
i__3[3] = 1, a__2[3] = "\000";
i__3[4] = 1, a__2[4] = "\377";
i__3[5] = 1, a__2[5] = "\001";
*(unsigned char *)&ch__5[0] = *ljob + 27;
i__3[6] = 1, a__2[6] = ch__5;
s_cat(ch__3, a__2, i__3, &c__7, (ftnlen)12);
do_fio(&c__1, ch__3, (ftnlen)12);
e_wsfe();
/* Text header */
/* * //char(0)//char(255)//char(1)//char(ljob+26) */
if (commidi_1.debugmidi) {
s_wsfe(&io___1751);
do_fio(&c__1, "\"MTrk\"", (ftnlen)6);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ib1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ib0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__255, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
i__2 = *ljob + 27;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
e_wsfe();
}
s_wsfe(&io___1752);
do_fio(&c__1, jobname, (*ljob));
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1753);
/* Writing concatenation */
i__4[0] = 1, a__3[0] = "\"";
i__4[1] = *ljob, a__3[1] = jobname;
i__4[2] = 1, a__3[2] = "\"";
s_cat(ch__6, a__3, i__4, &c__3, (ftnlen)46);
do_fio(&c__1, ch__6, *ljob + 2);
e_wsfe();
}
/* (separate writes are needed to defeat compiler BUG!!!) */
/* write(51,'(a,$)')'.mid, produced by PMX 2.30' */
s_wsfe(&io___1754);
/* Writing concatenation */
i__5[0] = 22, a__4[0] = ".mid, produced by PMX ";
i__5[1] = 5, a__4[1] = comver_1.versionc;
s_cat(ch__7, a__4, i__5, &c__2, (ftnlen)27);
do_fio(&c__1, ch__7, (ftnlen)27);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1755);
/* Writing concatenation */
i__4[0] = 23, a__3[0] = "\".mid, produced by PMX ";
i__4[1] = 5, a__3[1] = comver_1.versionc;
i__4[2] = 1, a__3[2] = "\"";
s_cat(ch__8, a__3, i__4, &c__3, (ftnlen)29);
do_fio(&c__1, ch__8, (ftnlen)29);
e_wsfe();
}
/* Conductor event data: Loop over sections. */
i__2 = commmac_1.nmidsec;
for (isec = 1; isec <= i__2; ++isec) {
if (isec < commmac_1.nmidsec) {
mend = commmac_1.msecend[commidi_1.numchan + isec * 25 - 25];
} else {
mend = commidi_1.imidi[commidi_1.numchan];
}
i__6 = mend;
for (i__ = commmac_1.msecstrt[commidi_1.numchan + isec * 25 - 25];
i__ <= i__6; ++i__) {
s_wsfe(&io___1758);
*(unsigned char *)&ch__2[0] = (char) commidi_1.mmidi[
commidi_1.numchan + i__ * 25 - 25];
do_fio(&c__1, ch__2, (ftnlen)1);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1759);
do_fio(&c__1, (char *)&commidi_1.mmidi[commidi_1.numchan +
i__ * 25 - 25], (ftnlen)sizeof(shortint));
e_wsfe();
}
/* L17: */
}
/* L16: */
}
/* And close out the time sig / tempo track. */
s_wsfe(&io___1760);
do_fio(&c__1, "\000\377/\000", (ftnlen)4);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1761);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__255, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__47, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Loop over track for each voice: The following sets up iv. */
all_1.iv = all_1.nv;
if (commidi_1.twoline[all_1.nv - 1]) {
kv = 2;
} else {
kv = 1;
}
/* Moved to pmxab to allow midivel, bal, tran as functions of instrument */
/* rather than staff (iv) */
/* c */
/* c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv) */
/* c */
/* nstaves = 0 */
/* ivt = 0 */
/* do 12 iinst = 1 , nm */
/* nstaves = nstaves+nsperi(iinst) */
/* do 13 ivtt = 1 , nsperi(iinst) */
/* ivt = ivt+1 */
/* iinsiv(ivt) = iinst */
/* 13 continue */
/* if (nstaves .eq. nv) go to 14 */
/* 12 continue */
/* print*,'Screwup!' */
/* call stop1() */
/* 14 continue */
i__2 = commidi_1.numchan - 1;
for (icm = 0; icm <= i__2; ++icm) {
/* Get the number of bytes in the data stream */
ndata = commidi_1.imidi[icm] + 1 - commmac_1.msecstrt[icm +
commmac_1.nmidsec * 25 - 25];
i__6 = commmac_1.nmidsec - 1;
for (isec = 1; isec <= i__6; ++isec) {
ndata = ndata + 1 + commmac_1.msecend[icm + isec * 25 - 25] -
commmac_1.msecstrt[icm + isec * 25 - 25];
/* L11: */
}
/* c Add 3 (for instrum) plus 4 (for closing) to byte count, */
/* Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, */
/* ndata = ndata+7 */
ndata += 11;
/* Add 4+lnam(iinsiv(iv)) if lnam>0 , */
if (comtop_1.lnam[commvel_1.iinsiv[all_1.iv - 1] - 1] > 0) {
ndata = ndata + 4 + comtop_1.lnam[commvel_1.iinsiv[all_1.iv - 1]
- 1];
}
/* Separate total byte counts into 4 bytes */
for (ibyte = 1; ibyte <= 4; ++ibyte) {
if (ndata > 0) {
*(unsigned char *)&byteq[ibyte - 1] = (char) (ndata % 256);
ndata = lbit_shift(ndata, (ftnlen)-8);
} else {
*(unsigned char *)&byteq[ibyte - 1] = '\0';
}
/* L2: */
}
/* Now write front stuff for this track */
s_wsfe(&io___1766);
/* Writing concatenation */
i__7[0] = 4, a__5[0] = "MTrk";
i__7[1] = 1, a__5[1] = byteq + 3;
i__7[2] = 1, a__5[2] = byteq + 2;
i__7[3] = 1, a__5[3] = byteq + 1;
i__7[4] = 1, a__5[4] = byteq;
i__7[5] = 1, a__5[5] = "\000";
*(unsigned char *)&ch__2[0] = icmm[icm] + 192;
i__7[6] = 1, a__5[6] = ch__2;
*(unsigned char *)&ch__4[0] = commidi_1.midinst[commvel_1.iinsiv[
all_1.iv - 1] - 1];
i__7[7] = 1, a__5[7] = ch__4;
i__7[8] = 1, a__5[8] = "\000";
*(unsigned char *)&ch__5[0] = icmm[icm] + 176;
i__7[9] = 1, a__5[9] = ch__5;
i__7[10] = 1, a__5[10] = "\n";
*(unsigned char *)&ch__10[0] = commvel_1.midbc[icm];
i__7[11] = 1, a__5[11] = ch__10;
s_cat(ch__9, a__5, i__7, &c__12, (ftnlen)15);
do_fio(&c__1, ch__9, (ftnlen)15);
e_wsfe();
/* * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) */
if (commidi_1.debugmidi) {
s_wsfe(&io___1767);
do_fio(&c__1, "icm=", (ftnlen)4);
do_fio(&c__1, (char *)&icm, (ftnlen)sizeof(integer));
do_fio(&c__1, " \"MTrk\"", (ftnlen)7);
i__6 = *(unsigned char *)&byteq[3];
do_fio(&c__1, (char *)&i__6, (ftnlen)sizeof(integer));
i__8 = *(unsigned char *)&byteq[2];
do_fio(&c__1, (char *)&i__8, (ftnlen)sizeof(integer));
i__9 = *(unsigned char *)&byteq[1];
do_fio(&c__1, (char *)&i__9, (ftnlen)sizeof(integer));
i__10 = *(unsigned char *)&byteq[0];
do_fio(&c__1, (char *)&i__10, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
i__11 = icmm[icm] + 192;
do_fio(&c__1, (char *)&i__11, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&commidi_1.midinst[commvel_1.iinsiv[
all_1.iv - 1] - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
i__12 = icmm[icm] + 176;
do_fio(&c__1, (char *)&i__12, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__10, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&commvel_1.midbc[icm], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), */
if (comtop_1.lnam[commvel_1.iinsiv[all_1.iv - 1] - 1] > 0) {
/* Add instrument name as sequence name */
s_wsfe(&io___1768);
/* Writing concatenation */
i__5[0] = 3, a__4[0] = "\000\377\003";
*(unsigned char *)&ch__2[0] = comtop_1.lnam[commvel_1.iinsiv[
all_1.iv - 1] - 1];
i__5[1] = 1, a__4[1] = ch__2;
s_cat(ch__11, a__4, i__5, &c__2, (ftnlen)4);
do_fio(&c__1, ch__11, (ftnlen)4);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1769);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__255, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&comtop_1.lnam[commvel_1.iinsiv[
all_1.iv - 1] - 1], (ftnlen)sizeof(integer));
e_wsfe();
}
s_wsfe(&io___1770);
do_fio(&c__1, comtop_1.inameq + (commvel_1.iinsiv[all_1.iv - 1] -
1) * 79, comtop_1.lnam[commvel_1.iinsiv[all_1.iv - 1] - 1]
);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1771);
/* Writing concatenation */
i__4[0] = 1, a__3[0] = "\"";
i__4[1] = comtop_1.lnam[commvel_1.iinsiv[all_1.iv - 1] - 1],
a__3[1] = comtop_1.inameq + (commvel_1.iinsiv[
all_1.iv - 1] - 1) * 79;
i__4[2] = 1, a__3[2] = "\"";
s_cat(ch__12, a__3, i__4, &c__3, (ftnlen)81);
do_fio(&c__1, ch__12, comtop_1.lnam[commvel_1.iinsiv[all_1.iv
- 1] - 1] + 2);
e_wsfe();
}
}
s_wsfi(&io___1773);
do_fio(&c__1, (char *)&icm, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___1775);
do_fio(&c__1, (char *)&commidi_1.midinst[commvel_1.iinsiv[all_1.iv -
1] - 1], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 16, a__1[0] = "MIDI instrument ";
i__1[1] = 2, a__1[1] = tempoq;
i__1[2] = 4, a__1[2] = " is ";
i__1[3] = 3, a__1[3] = instq;
s_cat(ch__13, a__1, i__1, &c__4, (ftnlen)25);
printl_(ch__13, (ftnlen)25);
/* Notes: Loop over sections. */
i__6 = commmac_1.nmidsec;
for (isec = 1; isec <= i__6; ++isec) {
if (isec < commmac_1.nmidsec) {
mend = commmac_1.msecend[icm + isec * 25 - 25];
} else {
mend = commidi_1.imidi[icm];
}
i__8 = mend;
for (i__ = commmac_1.msecstrt[icm + isec * 25 - 25]; i__ <= i__8;
++i__) {
s_wsfe(&io___1776);
*(unsigned char *)&ch__2[0] = (char) commidi_1.mmidi[icm +
i__ * 25 - 25];
do_fio(&c__1, ch__2, (ftnlen)1);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1777);
do_fio(&c__1, (char *)&commidi_1.mmidi[icm + i__ * 25 -
25], (ftnlen)sizeof(shortint));
e_wsfe();
}
/* L10: */
}
/* L9: */
}
/* Closing 4 bytes */
s_wsfe(&io___1778);
/* Writing concatenation */
chax_(ch__2, (ftnlen)1, &c__0);
i__1[0] = 1, a__1[0] = ch__2;
i__1[1] = 1, a__1[1] = "\377";
i__1[2] = 1, a__1[2] = "/";
i__1[3] = 1, a__1[3] = "\000";
s_cat(ch__11, a__1, i__1, &c__4, (ftnlen)4);
do_fio(&c__1, ch__11, (ftnlen)4);
e_wsfe();
if (commidi_1.debugmidi) {
s_wsfe(&io___1779);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__255, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__47, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
}
if (kv == 2) {
kv = 1;
} else if (all_1.iv == 1) {
goto L5;
} else {
--all_1.iv;
if (commidi_1.twoline[all_1.iv - 1]) {
kv = 2;
}
}
L5:
;
}
s_wsfe(&io___1780);
do_fio(&c__1, "Bytes used:", (ftnlen)11);
i__2 = commidi_1.numchan;
for (icm = 0; icm <= i__2; ++icm) {
do_fio(&c__1, (char *)&commidi_1.imidi[icm], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___1781);
do_fio(&c__1, "Bytes used:", (ftnlen)11);
i__2 = commidi_1.numchan;
for (icm = 0; icm <= i__2; ++icm) {
do_fio(&c__1, (char *)&commidi_1.imidi[icm], (ftnlen)sizeof(integer));
}
e_wsfe();
cl__1.cerr = 0;
cl__1.cunit = 51;
cl__1.csta = 0;
f_clos(&cl__1);
if (commidi_1.debugmidi) {
cl__1.cerr = 0;
cl__1.cunit = 52;
cl__1.csta = 0;
f_clos(&cl__1);
}
return 0;
} /* writemidi_ */
/* Subroutine */ int writesetsign_(integer *ninsttrans, integer *iinsttrans,
integer *itranskey, logical *flag__)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2[2], i__3;
char ch__1[1], ch__2[80];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
static integer i__;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer lnote;
static char notexq[79];
/* Fortran I/O blocks */
static cilist io___1785 = { 0, 11, 0, "(a)", 0 };
/* Assumes notexq is blank */
/* Parameter adjustments */
--itranskey;
--iinsttrans;
/* Function Body */
i__1 = *ninsttrans;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 7, a__1[1] = "setsign";
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
lnote = 8;
if (iinsttrans[i__] < 10) {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__3 = iinsttrans[i__] + 48;
chax_(ch__1, (ftnlen)1, &i__3);
i__2[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++lnote;
} else {
i__3 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 4 - i__3;
ici__1.iciunit = notexq + i__3;
ici__1.icifmt = "(a1,i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
do_fio(&c__1, (char *)&iinsttrans[i__], (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
lnote += 4;
}
if (itranskey[i__] < 0) {
i__3 = lnote;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = lnote + 4 - i__3;
ici__1.iciunit = notexq + i__3;
ici__1.icifmt = "(a1,i2,a1)";
s_wsfi(&ici__1);
do_fio(&c__1, "{", (ftnlen)1);
do_fio(&c__1, (char *)&itranskey[i__], (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
lnote += 4;
} else {
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__3 = itranskey[i__] + 48;
chax_(ch__1, (ftnlen)1, &i__3);
i__2[1] = 1, a__1[1] = ch__1;
s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79);
++lnote;
}
s_wsfe(&io___1785);
/* Writing concatenation */
i__2[0] = lnote, a__1[0] = notexq;
i__2[1] = 1, a__1[1] = "%";
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)80);
do_fio(&c__1, ch__2, lnote + 1);
e_wsfe();
/* L1: */
}
*flag__ = FALSE_;
return 0;
} /* writesetsign_ */
/* Subroutine */ int writflot_(real *x, char *notexq, integer *lenline,
ftnlen notexq_len)
{
/* System generated locals */
integer i__1;
icilist ici__1;
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
if (*x < .95f) {
i__1 = *lenline;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lenline + 2 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f2.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(real));
e_wsfi();
*lenline += 2;
} else if (*x < 9.95f) {
i__1 = *lenline;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lenline + 3 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f3.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(real));
e_wsfi();
*lenline += 3;
} else {
i__1 = *lenline;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = *lenline + 4 - i__1;
ici__1.iciunit = notexq + i__1;
ici__1.icifmt = "(f4.1)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(real));
e_wsfi();
*lenline += 4;
}
return 0;
} /* writflot_ */
/* Subroutine */ int wsclef_(integer *iv, integer *ninow, char *clefq,
integer *nclef, ftnlen clefq_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1, i__2[3], i__3[2], i__4;
char ch__1[1], ch__2[1], ch__3[9], ch__4[22];
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char
*, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
static integer iv1, iv2, iiv;
extern /* Character */ VOID chax_(char *, ftnlen, integer *);
static integer ltem;
static char temq[20];
extern /* Subroutine */ int stop1_(void);
static integer iinst;
extern integer numclef_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___1788 = { 0, 6, 0, 0, 0 };
static cilist io___1789 = { 0, 6, 0, 0, 0 };
static icilist io___1793 = { 0, temq, 0, "(a9,i2,a1)", 20, 1 };
static cilist io___1794 = { 0, 11, 0, "(a)", 0 };
static cilist io___1796 = { 0, 11, 0, "(a)", 0 };
/* Writes \setclef for instrument containing voice iv */
/* Parameter adjustments */
--clefq;
/* Function Body */
if (*nclef < 7) {
i__1 = *nclef + 48;
chax_(ch__1, (ftnlen)1, &i__1);
*(unsigned char *)&clefq[*iv] = *(unsigned char *)&ch__1[0];
} else {
*(unsigned char *)&clefq[*iv] = '9';
}
if (! comlast_1.islast) {
return 0;
}
iv1 = 1;
i__1 = *ninow;
for (iinst = 1; iinst <= i__1; ++iinst) {
if (*iv < iv1 + comnvi_1.nspern[iinst - 1]) {
goto L2;
}
iv1 += comnvi_1.nspern[iinst - 1];
/* L1: */
}
s_wsle(&io___1788);
e_wsle();
s_wsle(&io___1789);
do_lio(&c__9, &c__1, "Should not be here in wsclef!", (ftnlen)29);
e_wsle();
stop1_();
L2:
iv2 = iv1 + comnvi_1.nspern[iinst - 1] - 1;
if (iinst < 10) {
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__2[0] = 1, a__1[0] = ch__1;
i__2[1] = 7, a__1[1] = "setclef";
i__1 = iinst + 48;
chax_(ch__2, (ftnlen)1, &i__1);
i__2[2] = 1, a__1[2] = ch__2;
s_cat(temq, a__1, i__2, &c__3, (ftnlen)20);
ltem = 9;
} else {
s_wsfi(&io___1793);
/* Writing concatenation */
chax_(ch__1, (ftnlen)1, &c__92);
i__3[0] = 1, a__2[0] = ch__1;
i__3[1] = 8, a__2[1] = "setclef{";
s_cat(ch__3, a__2, i__3, &c__2, (ftnlen)9);
do_fio(&c__1, ch__3, (ftnlen)9);
do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof(integer));
do_fio(&c__1, "}", (ftnlen)1);
e_wsfi();
ltem = 12;
}
if (iv1 == iv2) {
s_wsfe(&io___1794);
/* Writing concatenation */
i__2[0] = ltem, a__1[0] = temq;
i__2[1] = 1, a__1[1] = clefq + *iv;
i__2[2] = 1, a__1[2] = "%";
s_cat(ch__4, a__1, i__2, &c__3, (ftnlen)22);
do_fio(&c__1, ch__4, ltem + 2);
e_wsfe();
} else {
/* Writing concatenation */
i__3[0] = ltem, a__2[0] = temq;
i__3[1] = 1, a__2[1] = "{";
s_cat(temq, a__2, i__3, &c__2, (ftnlen)20);
++ltem;
i__1 = iv2;
for (iiv = iv1; iiv <= i__1; ++iiv) {
/* Writing concatenation */
i__3[0] = ltem, a__2[0] = temq;
i__4 = numclef_(clefq + iiv, (ftnlen)1) + 48;
chax_(ch__1, (ftnlen)1, &i__4);
i__3[1] = 1, a__2[1] = ch__1;
s_cat(temq, a__2, i__3, &c__2, (ftnlen)20);
++ltem;
/* L3: */
}
s_wsfe(&io___1796);
/* Writing concatenation */
i__3[0] = ltem, a__2[0] = temq;
i__3[1] = 2, a__2[1] = "}%";
s_cat(ch__4, a__2, i__3, &c__2, (ftnlen)22);
do_fio(&c__1, ch__4, ltem + 2);
e_wsfe();
}
return 0;
} /* wsclef_ */
/* Main program alias */ int pmxab_ () { MAIN__ (); return 0; }