From ff3def13189580da6fe5254355c8f3b8091bb0fb Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Fri, 18 May 2012 00:35:36 +0000 Subject: pmx 2.6.18 (16may12) git-svn-id: svn://tug.org/texlive/trunk@26478 c570f23f-e606-0410-a88d-b1316a301751 --- Build/source/utils/pmx/ChangeLog | 4 + Build/source/utils/pmx/Makefile.am | 4 +- Build/source/utils/pmx/Makefile.in | 4 +- Build/source/utils/pmx/configure | 24 +- .../source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog | 19 + .../source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes | 13 + .../utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary | 17 + .../utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix | 19 + .../pmx-2.6.18-PATCHES/patch-03-DOS-line-endings | 18 + .../pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex | 18 + .../pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t | 13 + Build/source/utils/pmx/pmx-2.6.18/AUTHORS | 1 + Build/source/utils/pmx/pmx-2.6.18/COPYING | 622 + Build/source/utils/pmx/pmx-2.6.18/ChangeLog | 206 + Build/source/utils/pmx/pmx-2.6.18/INSTALL | 365 + Build/source/utils/pmx/pmx-2.6.18/Makefile.am | 238 + Build/source/utils/pmx/pmx-2.6.18/NEWS | 1 + Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 | 40 + Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 | 31 + Build/source/utils/pmx/pmx-2.6.18/README | 11 + Build/source/utils/pmx/pmx-2.6.18/arith.h | 0 Build/source/utils/pmx/pmx-2.6.18/config.h.in | 90 + Build/source/utils/pmx/pmx-2.6.18/configure.ac | 42 + Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile | 61 + Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice | 23 + Build/source/utils/pmx/pmx-2.6.18/libf2c/README | 329 + Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c | 22 + .../source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c | 225 + .../source/utils/pmx/pmx-2.6.18/libf2c/backspac.c | 76 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c | 20 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c | 23 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c | 53 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c | 25 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c | 23 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c | 23 + Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c | 41 + Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c | 33 + Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c | 101 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_abs.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c | 21 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c | 46 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c | 20 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c | 20 + Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c | 151 + Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c | 26 + Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c | 63 + Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c | 77 + Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c | 25 + Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c | 20 + Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c | 160 + Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c | 22 + Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c | 22 + Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c | 282 + Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c | 57 + Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c | 43 + Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h | 223 + .../source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c | 44 + Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c | 93 + Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h | 142 + Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c | 525 + Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h | 104 + Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c | 51 + Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h | 28 + .../source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c | 52 + Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c | 52 + Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c | 34 + Build/source/utils/pmx/pmx-2.6.18/libf2c/getenv_.c | 62 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c | 32 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c | 343 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c | 32 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c | 17 + Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c | 159 + Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c | 83 + Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c | 117 + Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c | 18 + .../source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c | 68 + .../source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c | 17 + Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h | 74 + Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c | 805 + Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c | 314 + Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c | 147 + Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c | 299 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c | 26 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c | 41 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c | 39 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c | 39 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c | 39 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c | 41 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c | 60 + Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c | 29 + .../source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c | 72 + .../source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c | 17 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c | 16 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c | 21 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c | 46 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c | 20 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c | 19 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h | 41 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c | 550 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c | 30 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c | 91 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c | 109 + Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c | 616 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c | 86 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c | 50 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c | 57 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c | 96 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c | 32 + Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c | 48 + Build/source/utils/pmx/pmx-2.6.18/libf2c/sfe.c | 43 + Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c | 51 + Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h | 35 + Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c | 21 + Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c | 24 + Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c | 90 + Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h | 66 + Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c | 42 + .../source/utils/pmx/pmx-2.6.18/libf2c/typesize.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c | 75 + Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c | 368 + Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c | 54 + Build/source/utils/pmx/pmx-2.6.18/libf2c/wref.c | 294 + Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c | 377 + Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c | 78 + Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c | 42 + Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c | 32 + Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c | 77 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c | 18 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c | 21 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c | 50 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c | 23 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c | 121 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c | 21 + Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c | 35 + Build/source/utils/pmx/pmx-2.6.18/pmx.test | 25 + Build/source/utils/pmx/pmx-2.6.18/pmx2617.f | 23597 ++++++++++++ Build/source/utils/pmx/pmx-2.6.18/pmx2618.for | 23646 ++++++++++++ Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig | 23646 ++++++++++++ Build/source/utils/pmx/pmx-2.6.18/pmxab.c | 37988 +++++++++++++++++++ Build/source/utils/pmx/pmx-2.6.18/scor2prt.c | 2775 ++ Build/source/utils/pmx/pmx-2.6.18/scor2prt.f | 1619 + Build/source/utils/pmx/pmx-2.6.18/scor2prt.for | 1620 + .../source/utils/pmx/pmx-2.6.18/scor2prt.for.orig | 1619 + .../source/utils/pmx/pmx-2.6.18/tests/barsant.mid | Bin 0 -> 3077 bytes .../source/utils/pmx/pmx-2.6.18/tests/barsant.pml | 24 + .../source/utils/pmx/pmx-2.6.18/tests/barsant.pmx | 68 + .../source/utils/pmx/pmx-2.6.18/tests/barsant.tex | 307 + .../source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx | 48 + .../source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx | 66 + Build/source/utils/pmx/pmx-2.6.18/version.ac | 11 + Build/source/utils/pmx/pmx-2.6.18/w32getc.c | 14 + Build/source/utils/pmx/tests/barsant.mid | Bin 3077 -> 3077 bytes Build/source/utils/pmx/tests/barsant.pml | 2 +- Build/source/utils/pmx/version.ac | 2 +- 213 files changed, 130427 insertions(+), 18 deletions(-) create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex create mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t create mode 100644 Build/source/utils/pmx/pmx-2.6.18/AUTHORS create mode 100644 Build/source/utils/pmx/pmx-2.6.18/COPYING create mode 100644 Build/source/utils/pmx/pmx-2.6.18/ChangeLog create mode 100644 Build/source/utils/pmx/pmx-2.6.18/INSTALL create mode 100644 Build/source/utils/pmx/pmx-2.6.18/Makefile.am create mode 100644 Build/source/utils/pmx/pmx-2.6.18/NEWS create mode 100644 Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 create mode 100644 Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 create mode 100644 Build/source/utils/pmx/pmx-2.6.18/README create mode 100644 Build/source/utils/pmx/pmx-2.6.18/arith.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/config.h.in create mode 100644 Build/source/utils/pmx/pmx-2.6.18/configure.ac create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/README create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/getenv_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sfe.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wref.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c create mode 100755 Build/source/utils/pmx/pmx-2.6.18/pmx.test create mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmx2617.f create mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmx2618.for create mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig create mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmxab.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.c create mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.f create mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.for create mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx create mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx create mode 100644 Build/source/utils/pmx/pmx-2.6.18/version.ac create mode 100644 Build/source/utils/pmx/pmx-2.6.18/w32getc.c (limited to 'Build') diff --git a/Build/source/utils/pmx/ChangeLog b/Build/source/utils/pmx/ChangeLog index 9d507b1f556..abd84a025e9 100644 --- a/Build/source/utils/pmx/ChangeLog +++ b/Build/source/utils/pmx/ChangeLog @@ -1,3 +1,7 @@ +2012-05-18 Karl Berry + + * pmx-2.6.18. + 2012-04-01 Peter Breitenlohner * w32getc.c (new): Handle DOS line endings (on Windows). diff --git a/Build/source/utils/pmx/Makefile.am b/Build/source/utils/pmx/Makefile.am index fb4500cb604..117121f71fb 100644 --- a/Build/source/utils/pmx/Makefile.am +++ b/Build/source/utils/pmx/Makefile.am @@ -235,7 +235,7 @@ EXTRA_libf2c_a_SOURCES += \ EXTRA_libf2c_a_SOURCES += \ $(PMX_TREE)/libf2c/signbit.c -lua_scripts = pmx +lua_scripts = pmx2pdf scriptsdir = texmf-dist/scripts/pmx nodist_bin_SCRIPTS = @@ -249,7 +249,7 @@ install-data-hook: install-lua-links uninstall-hook: uninstall-links -dist_man1_MANS = pmx.1 pmxab.1 scor2prt.1 +dist_man1_MANS = pmx2pdf.1 pmxab.1 scor2prt.1 ## Tests ## diff --git a/Build/source/utils/pmx/Makefile.in b/Build/source/utils/pmx/Makefile.in index 9062b06b9be..b96e46f01c4 100644 --- a/Build/source/utils/pmx/Makefile.in +++ b/Build/source/utils/pmx/Makefile.in @@ -484,7 +484,7 @@ EXTRA_libf2c_a_SOURCES = $(PMX_TREE)/libf2c/uninit.c \ $(PMX_TREE)/libf2c/ftell64_.c $(PMX_TREE)/libf2c/pow_qq.c \ $(PMX_TREE)/libf2c/qbitbits.c $(PMX_TREE)/libf2c/qbitshft.c \ $(PMX_TREE)/libf2c/signbit.c -lua_scripts = pmx +lua_scripts = pmx2pdf scriptsdir = texmf-dist/scripts/pmx nodist_bin_SCRIPTS = $(am__append_2) all_scripts = $(lua_scripts) $(perl_scripts) $(shell_scripts) @@ -492,7 +492,7 @@ all_scripts = $(lua_scripts) $(perl_scripts) $(shell_scripts) @WIN32_TRUE@@WIN32_WRAP_TRUE@runscript = $(top_srcdir)/../../texk/texlive/w32_wrapper/runscript.exe texmfdir = $(datarootdir)/$(scriptsdir) dist_texmf_SCRIPTS = $(lua_scripts:=.lua) -dist_man1_MANS = pmx.1 pmxab.1 scor2prt.1 +dist_man1_MANS = pmx2pdf.1 pmxab.1 scor2prt.1 TESTS = pmx.test DISTCLEANFILES = barsant* pmxaerr.dat all: all-am diff --git a/Build/source/utils/pmx/configure b/Build/source/utils/pmx/configure index 828e0c10433..1e5b69f192b 100755 --- a/Build/source/utils/pmx/configure +++ b/Build/source/utils/pmx/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for pmx for TeX Live 2.6.17. +# Generated by GNU Autoconf 2.69 for pmx for TeX Live 2.6.18. # # Report bugs to . # @@ -580,12 +580,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='pmx for TeX Live' PACKAGE_TARNAME='pmx-for-tex-live' -PACKAGE_VERSION='2.6.17' -PACKAGE_STRING='pmx for TeX Live 2.6.17' +PACKAGE_VERSION='2.6.18' +PACKAGE_STRING='pmx for TeX Live 2.6.18' PACKAGE_BUGREPORT='tex-k@tug.org' PACKAGE_URL='' -ac_unique_file="pmx-2.6.17/pmxab.c" +ac_unique_file="pmx-2.6.18/pmxab.c" # Factoring default headers for most tests. ac_includes_default="\ #include @@ -1275,7 +1275,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures pmx for TeX Live 2.6.17 to adapt to many kinds of systems. +\`configure' configures pmx for TeX Live 2.6.18 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1342,7 +1342,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of pmx for TeX Live 2.6.17:";; + short | recursive ) echo "Configuration of pmx for TeX Live 2.6.18:";; esac cat <<\_ACEOF @@ -1437,7 +1437,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -pmx for TeX Live configure 2.6.17 +pmx for TeX Live configure 2.6.18 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1831,7 +1831,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by pmx for TeX Live $as_me 2.6.17, which was +It was created by pmx for TeX Live $as_me 2.6.18, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2665,7 +2665,7 @@ fi # Define the identity of the package. PACKAGE='pmx-for-tex-live' - VERSION='2.6.17' + VERSION='2.6.18' cat >>confdefs.h <<_ACEOF @@ -4524,7 +4524,7 @@ if test $ac_cv_sizeof_long_long -lt 8; then AM_CPPFLAGS="$AM_CPPPFLAGS -DNO_LONG_LONG" fi -PMX_TREE=pmx-2.6.17 +PMX_TREE=pmx-2.6.18 ac_config_files="$ac_config_files Makefile" @@ -5107,7 +5107,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by pmx for TeX Live $as_me 2.6.17, which was +This file was extended by pmx for TeX Live $as_me 2.6.18, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -5164,7 +5164,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -pmx for TeX Live config.status 2.6.17 +pmx for TeX Live config.status 2.6.18 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog new file mode 100644 index 00000000000..783c0504d7a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog @@ -0,0 +1,19 @@ +2012-04-01 Peter Breitenlohner + + * patch-05-FreeBSD-off_t (new): Build fix for FreeBSD. + Mail from Nikola Lecic [tlbuild] 21 Apr 2012 20:40:21. + +2012-04-01 Peter Breitenlohner + + * patch-03-DOS-line-endings, patch-04-MSVC-complex (new): WIN32. + Mail from Akira, 31 Mar 2012 21:36:26. + +2012-03-28 Peter Breitenlohner + + * patch-01-binary (new): Always use binary mode for WIN32. + Mail from Akira, 29 Mar 2012 23:50:53. + + * patch-02-bugfix (new): Bug fix, should be fixed in Fortran. + +Copyright (C) 2012 Peter Breitenlohner +You may freely use, modify and/or distribute this file. diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes new file mode 100644 index 00000000000..8e04162140c --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes @@ -0,0 +1,13 @@ +Changes applied to the pmx-2.6.18 tree as obtained from: + http://www.ctan.org/tex-archive/support/pmx/ + +Remove: + Makefile.in + aclocal.m4 + configure + depcomp + install-sh + missing + +(looks like the tests and other things are now in the dist, but have to +ignore that right now, sorry. --karl) diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary new file mode 100644 index 00000000000..16819f76212 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary @@ -0,0 +1,17 @@ + On Windows fseek() etc. are meaningful only for binary access. + + Mail from Akira, 29 Mar 2012 23:50:53. + +diff -ur pmx-2.6.17.orig/libf2c/open.c pmx-2.6.17/libf2c/open.c +--- pmx-2.6.17.orig/libf2c/open.c 2012-03-26 12:09:53.000000000 +0200 ++++ pmx-2.6.17/libf2c/open.c 2012-03-29 17:12:53.000000000 +0200 +@@ -30,6 +30,9 @@ + #ifdef NON_ANSI_RW_MODES + char *f__r_mode[2] = {"r", "r"}; + char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; ++#elif defined(WIN32) ++char *f__r_mode[2] = {"rb", "rb"}; ++char *f__w_mode[4] = {"wb", "wb", "rb+", "rb+"}; + #else + char *f__r_mode[2] = {"rb", "r"}; + char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix new file mode 100644 index 00000000000..58de7f58ef1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix @@ -0,0 +1,19 @@ + This should really be fixed in the Fortran source. + +diff -ur pmx-2.6.17.orig/scor2prt.c pmx-2.6.17/scor2prt.c +--- pmx-2.6.17.orig/scor2prt.c 2012-03-25 00:00:34.000000000 +0100 ++++ pmx-2.6.17/scor2prt.c 2012-03-29 16:59:56.000000000 +0200 +@@ -22,10 +22,10 @@ + integer nvi[24], nsyst, nvnow; + }; + struct all_2_ { +- integer noinow, iorig[24], noinst, insetup; +- real replacing; ++ integer noinow, iorig[24], noinst; ++ logical insetup, replacing; + integer instnum[24]; +- real botv[24]; ++ logical botv[24]; + integer nvi[24], nsyst, nvnow; + }; + diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings new file mode 100644 index 00000000000..5e36c101b5a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings @@ -0,0 +1,18 @@ + Handle DOS line endings (using additional file ../w32getc.c). + + Mail from Akira, 31 Mar 2012 21:36:26. + +diff -ur pmx-2.6.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h +--- pmx-2.6.17.orig/libf2c/fio.h 2012-03-26 12:09:53.000000000 +0200 ++++ pmx-2.6.17/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200 +@@ -2,6 +2,10 @@ + #include "sysdep1.h" + #endif + #include "stdio.h" ++#ifdef WIN32 ++extern int w32getc(FILE *f); ++#define getc w32getc ++#endif + #include "errno.h" + #ifndef NULL + /* ANSI C */ diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex new file mode 100644 index 00000000000..4017e79ac99 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex @@ -0,0 +1,18 @@ + _COMPLEX_DEFINED should be defined for MSVC, otherwise + complex is redefined inconsistently in . + + Mail from Akira, 31 Mar 2012 21:36:26. + +diff -ur pmx-2.6.17.orig/libf2c/f2c.h pmx-2.6.17/libf2c/f2c.h +--- pmx-2.6.17.orig/libf2c/f2c.h 2012-03-26 12:09:53.000000000 +0200 ++++ pmx-2.6.17/libf2c/f2c.h 2012-04-01 14:50:19.000000000 +0200 +@@ -13,6 +13,9 @@ + typedef short int shortint; + typedef float real; + typedef double doublereal; ++#ifdef WIN32 ++#define _COMPLEX_DEFINED 1 ++#endif + typedef struct { real r, i; } complex; + typedef struct { doublereal r, i; } doublecomplex; + typedef long int logical; diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t new file mode 100644 index 00000000000..8131c75d023 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t @@ -0,0 +1,13 @@ + On FreeBSD (and maybe others) we need for off_t. + +diff -ur pmx-2.6.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h +--- pmx-2.6.17.orig/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200 ++++ pmx-2.6.17/libf2c/fio.h 2012-04-23 10:06:01.000000000 +0200 +@@ -1,6 +1,7 @@ + #ifndef SYSDEP_H_INCLUDED + #include "sysdep1.h" + #endif ++#include /* for off_t */ + #include "stdio.h" + #ifdef WIN32 + extern int w32getc(FILE *f); diff --git a/Build/source/utils/pmx/pmx-2.6.18/AUTHORS b/Build/source/utils/pmx/pmx-2.6.18/AUTHORS new file mode 100644 index 00000000000..2fa3681a96f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/AUTHORS @@ -0,0 +1 @@ +Don Simons dsimons@roadrunner.com diff --git a/Build/source/utils/pmx/pmx-2.6.18/COPYING b/Build/source/utils/pmx/pmx-2.6.18/COPYING new file mode 100644 index 00000000000..92bc3d8dc11 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/COPYING @@ -0,0 +1,622 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + diff --git a/Build/source/utils/pmx/pmx-2.6.18/ChangeLog b/Build/source/utils/pmx/pmx-2.6.18/ChangeLog new file mode 100644 index 00000000000..a6bdd7ee272 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/ChangeLog @@ -0,0 +1,206 @@ +Changes from PMX 2.5 to 2.603, 15 April 2011 + +2.501 (Note: new scor2prt) + +Bugfix: initialize index in PMX subroutine putorn to eliminate subscript +error detected in some compilers Bugfix in scor2prt: Ignore special +treatment of special symbols if they appear between double quotes. +Tweak: move end of first part of line­break ties slightly to the right. + +2.502 (Note: new pmx.tex) + +The height of a figured bass vertical stack can now be adjusted upward by +an integral number of \internote by appending "+" and the number. Recall +that it can already be moved downward 4\internote by prepending "_" +(underscore). The two options can be combined to provide full control +over the vertical position. Ties can now be represented with braces +"{" before a note and "}" after. Both are equivalent to "t" after the +note. (Thanks to Dirk Laurie). In pmx.tex all the commands of the form +\font\...=\fontid sy1000 have been changed to \font\...=cmsy10 (Thanks +to Olivier Vogel). + +2.503 + +Enable arpeggio left shift with ?­[x] Allow musicsize of 24 and 29. +Bugfix: Fix bug introduced in 2.415 which caused error in printing +replacement number in xtup. + +2.504 + +Gap between normal grace and main note: X[x] as option to the G command, +where x is the gap size in notehead widths. Bugfix: og (segno) now +works OK when nv .ne. noinst. + +2.505 + +A new global option AK activates special rules for vertical positioning of +rests in two­voice staves. By way of background, without the new option, +rests in two­voice staves have default positions based on a simple rule +that is not context­sensitive: those in the lower voice (the one before +"//") are 4\internote below their single­voice default positions, +and those in the upper line are 2\internote above the single­voice +default. The new option invokes a set of context­sensitive rules to +set the default position. The baseline rule is to align the rest in +a horizontal line with the next following note in the same bar. If +there is no following note in the bar, then it is aligned with the next +prior note. If there are simulataneous rests in both voices, the old +rule is applied. When the AK option is in force, it only affects places +where there are two voices in a staff. It may be toggled on and off at +the beginning of any input block, using just AK. When the option is in +effect, any user­defined tweaks on the height of a rest will supersede +the option for that particular rest, i.e., the tweak will be applied +relative to the single­voice default position. + +2.506 + +Fixes a bug in AK. Simultaneous, equal­duration rests will be positioned +according to the default rules. + +2.507 + +Enhancement to global option AK for vertical positioning of rests in +two­voice staves (see version 2.505): The option L ("look left") in a rest +will cause the vertical position of that rest to be based on the preceding +note, rather than the following one as is the default when AK has been +issued Partial bugfix: In unbeamed xtuplets, the length of the bracket +and position of the number are now adjusted to account for any inserted +hardspaces. Bugfix: unbeamed xtups with two flags are now allowed. + +2.508 + +Allow grace notes in xtuplets. + +2.509 + +Correct small bug in arpeggio left­shifting (it got confused when there +was more than one voice on a staff). + +2.510 + +Bugfix: Correct omission of character variable declarations in new +subroutine getgrace introduced in 2.508. + +2.511 (Note: new scor2prt named s2p2511.exe) + +Bugfix: Correct error in horizontal spacing introduced in 2.507. +Experiment: Remove prohibition against tempo changes in MIDI macros. +Bugfix in scor2prt: Make it work right when "R" command occurs at end +of input block and "/" is on next line (as produced by M­Tx). + +2.512 + +Enable multiplicity down­up "][" within xtuplet + +2.513 + +Bugfix: If there is more than one rest at start of a beamed xtuplet marked +as a forced beam, beam height and slope tweaks are now properly handled. +Bugfix: If an xtuplet with multiplicity 2 or 3 starts with a rest, the +rest is now printed correctly. Bugfix: Unbeamed xtuplets (with option +'a' on first note) with multiplicity 2 or 3 are now printed correctly. + +2.514 + +Bugfix: Correct horizontal spacing when after­grace is immediately +followed by normal grace. Bugfix: Correct transpose register when it +has been changed in a single after­grace. + +2.515 + +Bugfix: Correct error in automatic forced beams. Before the fix, if the +beam did not start an integral number of beam durations from the start +of the bar, incorrect results would occur. Bugfix: Properly center +fermata over centered whole­bar rest. + +2.516 (Note: new pmx.tex) + +Allow figures in voice #2. + +2.517 + +Allow figures in two voices, voice 1 and any other one. + +2.518 + +Bug fixes in 2­voice figures. + +2.519 + +Fix bug that prevented \sk from being output, misaligning some voices. + +2.520 + +New feature: special characters 2+, 4+, 5+, 6+, 9+ for figured bass. In +the PMX string for any figure, follow the number by 's'. This uses the +font cmrj from the new package figbas. You must install this font in +your TeX setup for this to work. + +2.521 + +Bugfix: Font definition syntax corrected so no extra space is introduced. + +2.602 (Note: new pmx.tex; requires eTeX) + +Allow 24 voices, beams, slurs. Require etex. Include comment about +doubling size of internal buffer to 131072, requiring gfortran for +Windows to compile. Correct slur indexing in linebreakslurs. Account for +comment lines in line count for error messages + +2.603 (Note: new scor2prt) + +In getpmxmod.for, decrease nline by 2 to fix locating errors following +reading in an include file. Add some error messages in g1etset.for +setup data + +2.610 + +Instrument-wise transposition: Ki[instrument #][+/-][trans +amt.][+/-][new key]. For more than one instrument, may immediately +repeat everything after "K". Must either be at start of score (right +after setup), or if later, must be preceded by normal (full score) key +change command K+0[+/-][new key]. Must be used with relative accidentals +("Ar"). Part(s) to be transposed must be entered in concert key, and +will appear transposed in the score. MIDI behavior not yet tested. +Has not yet been integrated into scor2prt, so for now if you want to +make parts, only use Ki... as score-only (on line after "%%") and/or +instrument only (on same line after %[Instrument #]). + +2.613 + +Set error trap if "D" is entered before any notes. + +Enhance "AS" to allow spacing adjustments tailored for either smallsize +or tinysize. As before, "AS" must be followed by nv characters, but now +they may be "0" for normal, "-" or "s" for small, or "t" for tiny. Still +must set sizes of instruments with inline TeX. + +Bugfix: Fixed broken "K-..." in 2.610. + +2.614 + +Bugfix: revise raised dotted rests by separately raising rest and dot. + +2.615 *(Note: new scor2prt)* + +Command "AS", described above under 2.163, now also causes staff sizes +to change (in score only, not parts), so inline TeX is no longer needed +to change sizes of selected staves. + +Scor2prt transfers partwise transposition commands Ki... (see 2.610 +above) into parts. + +2.616 + +"Feature" added: Hairpin dynamics now may span input blocks. + +2.617 + +Repaired several obscure bugs related to platform and compiler +dependencies; see pmxab.f for details. + +2.6.18 + +For letter and a4 paper respectively, commands "Acl" and "Ac4" set +horizontal and vertical sizes and offsets that center the page with no +further adjustments required in dvips. + diff --git a/Build/source/utils/pmx/pmx-2.6.18/INSTALL b/Build/source/utils/pmx/pmx-2.6.18/INSTALL new file mode 100644 index 00000000000..7d1c323beae --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/INSTALL @@ -0,0 +1,365 @@ +Installation Instructions +************************* + +Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, +2006, 2007, 2008, 2009 Free Software Foundation, Inc. + + Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. This file is offered as-is, +without warranty of any kind. + +Basic Installation +================== + + Briefly, the shell commands `./configure; make; make install' should +configure, build, and install this package. The following +more-detailed instructions are generic; see the `README' file for +instructions specific to this package. Some packages provide this +`INSTALL' file but do not implement all of the features documented +below. The lack of an optional feature in a given package is not +necessarily a bug. More recommendations for GNU packages can be found +in *note Makefile Conventions: (standards)Makefile Conventions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, and a +file `config.log' containing compiler output (useful mainly for +debugging `configure'). + + It can also use an optional file (typically called `config.cache' +and enabled with `--cache-file=config.cache' or simply `-C') that saves +the results of its tests to speed up reconfiguring. Caching is +disabled by default to prevent problems with accidental use of stale +cache files. + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If you are using the cache, and at +some point `config.cache' contains results you don't want to keep, you +may remove or edit it. + + The file `configure.ac' (or `configure.in') is used to create +`configure' by a program called `autoconf'. You need `configure.ac' if +you want to change it or regenerate `configure' using a newer version +of `autoconf'. + + The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. + + Running `configure' might take a while. While running, it prints + some messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package, generally using the just-built uninstalled binaries. + + 4. Type `make install' to install the programs and any data files and + documentation. When installing into a prefix owned by root, it is + recommended that the package be configured and built as a regular + user, and only the `make install' phase executed with root + privileges. + + 5. Optionally, type `make installcheck' to repeat any self-tests, but + this time using the binaries in their final installed location. + This target does not install anything. Running this target as a + regular user, particularly if the prior `make install' required + root privileges, verifies that the installation completed + correctly. + + 6. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + + 7. Often, you can also type `make uninstall' to remove the installed + files again. In practice, not all packages have tested that + uninstallation works correctly, even though it is required by the + GNU Coding Standards. + + 8. Some packages, particularly those that use Automake, provide `make + distcheck', which can by used by developers to test that all other + targets like `make install' and `make uninstall' work correctly. + This target is generally not run by end users. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. Run `./configure --help' +for details on some of the pertinent environment variables. + + You can give `configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here +is an example: + + ./configure CC=c99 CFLAGS=-g LIBS=-lposix + + *Note Defining Variables::, for more details. + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you can use GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. This +is known as a "VPATH" build. + + With a non-GNU `make', it is safer to compile the package for one +architecture at a time in the source code directory. After you have +installed the package for one architecture, use `make distclean' before +reconfiguring for another architecture. + + On MacOS X 10.5 and later systems, you can create libraries and +executables that work on multiple system types--known as "fat" or +"universal" binaries--by specifying multiple `-arch' options to the +compiler but only a single `-arch' option to the preprocessor. Like +this: + + ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CPP="gcc -E" CXXCPP="g++ -E" + + This is not guaranteed to produce working output in all cases, you +may have to build one architecture at a time and combine the results +using the `lipo' tool if you have problems. + +Installation Names +================== + + By default, `make install' installs the package's commands under +`/usr/local/bin', include files under `/usr/local/include', etc. You +can specify an installation prefix other than `/usr/local' by giving +`configure' the option `--prefix=PREFIX', where PREFIX must be an +absolute file name. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +pass the option `--exec-prefix=PREFIX' to `configure', the package uses +PREFIX as the prefix for installing programs and libraries. +Documentation and other data files still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=DIR' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. In general, the +default for these options is expressed in terms of `${prefix}', so that +specifying just `--prefix' will affect all of the other directory +specifications that were not explicitly provided. + + The most portable way to affect installation locations is to pass the +correct locations to `configure'; however, many packages provide one or +both of the following shortcuts of passing variable assignments to the +`make install' command line to change installation locations without +having to reconfigure or recompile. + + The first method involves providing an override variable for each +affected directory. For example, `make install +prefix=/alternate/directory' will choose an alternate location for all +directory configuration variables that were expressed in terms of +`${prefix}'. Any directories that were specified during `configure', +but not in terms of `${prefix}', must each be overridden at install +time for the entire installation to be relocated. The approach of +makefile variable overrides for each directory variable is required by +the GNU Coding Standards, and ideally causes no recompilation. +However, some platforms have known limitations with the semantics of +shared libraries that end up requiring recompilation when using this +method, particularly noticeable in packages that use GNU Libtool. + + The second method involves providing the `DESTDIR' variable. For +example, `make install DESTDIR=/alternate/directory' will prepend +`/alternate/directory' before all installation names. The approach of +`DESTDIR' overrides is not required by the GNU Coding Standards, and +does not work on platforms that have drive letters. On the other hand, +it does better at avoiding recompilation issues, and works well even +when some directory options were not specified in terms of `${prefix}' +at `configure' time. + +Optional Features +================= + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + + Some packages offer the ability to configure how verbose the +execution of `make' will be. For these packages, running `./configure +--enable-silent-rules' sets the default to minimal output, which can be +overridden with `make V=1'; while running `./configure +--disable-silent-rules' sets the default to verbose, which can be +overridden with `make V=0'. + +Particular systems +================== + + On HP-UX, the default C compiler is not ANSI C compatible. If GNU +CC is not installed, it is recommended to use the following options in +order to use an ANSI C compiler: + + ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" + +and if that doesn't work, install pre-built binaries of GCC for HP-UX. + + On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot +parse its `' header file. The option `-nodtk' can be used as +a workaround. If GNU CC is not installed, it is therefore recommended +to try + + ./configure CC="cc" + +and if that doesn't work, try + + ./configure CC="cc -nodtk" + + On Solaris, don't put `/usr/ucb' early in your `PATH'. This +directory contains several dysfunctional programs; working variants of +these programs are available in `/usr/bin'. So, if you need `/usr/ucb' +in your `PATH', put it _after_ `/usr/bin'. + + On Haiku, software installed for all users goes in `/boot/common', +not `/usr/local'. It is recommended to use the following options: + + ./configure --prefix=/boot/common + +Specifying the System Type +========================== + + There may be some features `configure' cannot figure out +automatically, but needs to determine by the type of machine the package +will run on. Usually, assuming the package is built to be run on the +_same_ architectures, `configure' can figure that out, but if it prints +a message saying it cannot guess the machine type, give it the +`--build=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name which has the form: + + CPU-COMPANY-SYSTEM + +where SYSTEM can have one of these forms: + + OS + KERNEL-OS + + See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the machine type. + + If you are _building_ compiler tools for cross-compiling, you should +use the option `--target=TYPE' to select the type of system they will +produce code for. + + If you want to _use_ a cross compiler, that generates code for a +platform different from the build platform, you should specify the +"host" platform (i.e., that on which the generated programs will +eventually be run) with `--host=TYPE'. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Defining Variables +================== + + Variables not defined in a site shell script can be set in the +environment passed to `configure'. However, some packages may run +configure again during the build, and the customized values of these +variables may be lost. In order to avoid this problem, you should set +them in the `configure' command line, using `VAR=value'. For example: + + ./configure CC=/usr/local2/bin/gcc + +causes the specified `gcc' to be used as the C compiler (unless it is +overridden in the site shell script). + +Unfortunately, this technique does not work for `CONFIG_SHELL' due to +an Autoconf bug. Until the bug is fixed you can use this workaround: + + CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash + +`configure' Invocation +====================== + + `configure' recognizes the following options to control how it +operates. + +`--help' +`-h' + Print a summary of all of the options to `configure', and exit. + +`--help=short' +`--help=recursive' + Print a summary of the options unique to this package's + `configure', and exit. The `short' variant lists options used + only in the top level, while the `recursive' variant lists options + also present in any nested packages. + +`--version' +`-V' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`--cache-file=FILE' + Enable the cache: use and save the results of the tests in FILE, + traditionally `config.cache'. FILE defaults to `/dev/null' to + disable caching. + +`--config-cache' +`-C' + Alias for `--cache-file=config.cache'. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--prefix=DIR' + Use DIR as the installation prefix. *note Installation Names:: + for more details, including other options available for fine-tuning + the installation locations. + +`--no-create' +`-n' + Run the configure checks, but stop before creating any output + files. + +`configure' also accepts some other, not widely useful, options. Run +`configure --help' for more details. + diff --git a/Build/source/utils/pmx/pmx-2.6.18/Makefile.am b/Build/source/utils/pmx/pmx-2.6.18/Makefile.am new file mode 100644 index 00000000000..d595ab06c79 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/Makefile.am @@ -0,0 +1,238 @@ +## Copyright (C) 2012 Peter Breitenlohner +## You may freely use, modify and/or distribute this file. +## + +INCLUDES = -I$(srcdir)/libf2c +AM_CFLAGS = #$(WARNING_CFLAGS) + +bin_PROGRAMS = pmxab scor2prt + +pmxab_SOURCES = pmxab.c + +scor2prt_SOURCES = scor2prt.c + +LDADD = libf2c.a + +noinst_LIBRARIES = libf2c.a + +## libf2c headers +libf2c_a_SOURCES = \ + arith.h \ + libf2c/f2c.h \ + libf2c/fio.h \ + libf2c/fmt.h \ + libf2c/fp.h \ + libf2c/lio.h \ + libf2c/rawio.h \ + libf2c/signal1.h \ + libf2c/sysdep1.h +## MISC +libf2c_a_SOURCES += \ + libf2c/abort_.c \ + libf2c/cabs.c \ + libf2c/derf_.c \ + libf2c/derfc_.c \ + libf2c/erf_.c \ + libf2c/erfc_.c \ + libf2c/exit_.c \ + libf2c/f77vers.c \ + libf2c/getarg_.c \ + libf2c/getenv_.c \ + libf2c/i77vers.c \ + libf2c/iargc_.c \ + libf2c/main.c \ + libf2c/s_paus.c \ + libf2c/s_rnge.c \ + libf2c/s_stop.c \ + libf2c/sig_die.c \ + libf2c/signal_.c \ + libf2c/system_.c +## MISC (not used for pmx) +EXTRA_libf2c_a_SOURCES = \ + libf2c/uninit.c +## POW +libf2c_a_SOURCES += \ + libf2c/pow_ci.c \ + libf2c/pow_dd.c \ + libf2c/pow_di.c \ + libf2c/pow_hh.c \ + libf2c/pow_ii.c \ + libf2c/pow_ri.c \ + libf2c/pow_zi.c \ + libf2c/pow_zz.c +## CX +libf2c_a_SOURCES += \ + libf2c/c_abs.c \ + libf2c/c_cos.c \ + libf2c/c_div.c \ + libf2c/c_exp.c \ + libf2c/c_log.c \ + libf2c/c_sin.c \ + libf2c/c_sqrt.c +## DCX +libf2c_a_SOURCES += \ + libf2c/z_abs.c \ + libf2c/z_cos.c \ + libf2c/z_div.c \ + libf2c/z_exp.c \ + libf2c/z_log.c \ + libf2c/z_sin.c \ + libf2c/z_sqrt.c +## REAL +libf2c_a_SOURCES += \ + libf2c/r_abs.c \ + libf2c/r_acos.c \ + libf2c/r_asin.c \ + libf2c/r_atan.c \ + libf2c/r_atn2.c \ + libf2c/r_cnjg.c \ + libf2c/r_cos.c \ + libf2c/r_cosh.c \ + libf2c/r_dim.c \ + libf2c/r_exp.c \ + libf2c/r_imag.c \ + libf2c/r_int.c \ + libf2c/r_lg10.c \ + libf2c/r_log.c \ + libf2c/r_mod.c \ + libf2c/r_nint.c \ + libf2c/r_sign.c \ + libf2c/r_sin.c \ + libf2c/r_sinh.c \ + libf2c/r_sqrt.c \ + libf2c/r_tan.c \ + libf2c/r_tanh.c +## DBL +libf2c_a_SOURCES += \ + libf2c/d_abs.c \ + libf2c/d_acos.c \ + libf2c/d_asin.c \ + libf2c/d_atan.c \ + libf2c/d_atn2.c \ + libf2c/d_cnjg.c \ + libf2c/d_cos.c \ + libf2c/d_cosh.c \ + libf2c/d_dim.c \ + libf2c/d_exp.c \ + libf2c/d_imag.c \ + libf2c/d_int.c \ + libf2c/d_lg10.c \ + libf2c/d_log.c \ + libf2c/d_mod.c \ + libf2c/d_nint.c \ + libf2c/d_prod.c \ + libf2c/d_sign.c \ + libf2c/d_sin.c \ + libf2c/d_sinh.c \ + libf2c/d_sqrt.c \ + libf2c/d_tan.c \ + libf2c/d_tanh.c +## INT +libf2c_a_SOURCES += \ + libf2c/i_abs.c \ + libf2c/i_dim.c \ + libf2c/i_dnnt.c \ + libf2c/i_indx.c \ + libf2c/i_len.c \ + libf2c/i_mod.c \ + libf2c/i_nint.c \ + libf2c/i_sign.c \ + libf2c/lbitbits.c \ + libf2c/lbitshft.c +## HALF +libf2c_a_SOURCES += \ + libf2c/h_abs.c \ + libf2c/h_dim.c \ + libf2c/h_dnnt.c \ + libf2c/h_indx.c \ + libf2c/h_len.c \ + libf2c/h_mod.c \ + libf2c/h_nint.c \ + libf2c/h_sign.c +## CMP +libf2c_a_SOURCES += \ + libf2c/hl_ge.c \ + libf2c/hl_gt.c \ + libf2c/hl_le.c \ + libf2c/hl_lt.c \ + libf2c/l_ge.c \ + libf2c/l_gt.c \ + libf2c/l_le.c \ + libf2c/l_lt.c +## EFL +libf2c_a_SOURCES += \ + libf2c/ef1asc_.c \ + libf2c/ef1cmc_.c +## CHAR +libf2c_a_SOURCES += \ + libf2c/f77_aloc.c \ + libf2c/s_cat.c \ + libf2c/s_cmp.c \ + libf2c/s_copy.c +## I77 +libf2c_a_SOURCES += \ + libf2c/backspac.c \ + libf2c/close.c \ + libf2c/dfe.c \ + libf2c/dolio.c \ + libf2c/due.c \ + libf2c/endfile.c \ + libf2c/err.c \ + libf2c/fmt.c \ + libf2c/fmtlib.c \ + libf2c/ftell_.c \ + libf2c/iio.c \ + libf2c/ilnw.c \ + libf2c/inquire.c \ + libf2c/lread.c \ + libf2c/lwrite.c \ + libf2c/open.c \ + libf2c/rdfmt.c \ + libf2c/rewind.c \ + libf2c/rsfe.c \ + libf2c/rsli.c \ + libf2c/rsne.c \ + libf2c/sfe.c \ + libf2c/sue.c \ + libf2c/typesize.c \ + libf2c/uio.c \ + libf2c/util.c \ + libf2c/wref.c \ + libf2c/wrtfmt.c \ + libf2c/wsfe.c \ + libf2c/wsle.c \ + libf2c/wsne.c \ + libf2c/xwsne.c +## TIME +libf2c_a_SOURCES += \ + libf2c/dtime_.c \ + libf2c/etime_.c + +## Handle DOS line endings +if WIN32 +libf2c_a_SOURCES += w32getc.c +endif WIN32 + +## QINT (unused) +EXTRA_libf2c_a_SOURCES += \ + libf2c/ftell64_.c \ + libf2c/pow_qq.c \ + libf2c/qbitbits.c \ + libf2c/qbitshft.c +## unused +EXTRA_libf2c_a_SOURCES += \ + libf2c/signbit.c + +## Tests +## +TESTS = pmx.test +EXTRA_DIST = $(TESTS) + +PATCHES = PATCH-2.6.18-01 PATCH-2.6.18-02 +## pmx.test +EXTRA_DIST += tests/barsant.mid tests/barsant.pml tests/barsant.pmx \ + tests/barsant.tex tests/barsant1.pmx tests/barsant2.pmx +EXTRA_DIST += scor2prt.for.orig scor2prt.for pmx2618.for.orig pmx2618.for +EXTRA_DIST += $(PATCHES) +DISTCLEANFILES = barsant* pmxaerr.dat + diff --git a/Build/source/utils/pmx/pmx-2.6.18/NEWS b/Build/source/utils/pmx/pmx-2.6.18/NEWS new file mode 100644 index 00000000000..533cebce439 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/NEWS @@ -0,0 +1 @@ +Missing logical declaration in sco2prt.for added (PATCH-2.6.18-01). diff --git a/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 b/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 new file mode 100644 index 00000000000..79b6bf23c46 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 @@ -0,0 +1,40 @@ +*** pmx2618.for.orig 2012-04-25 13:36:16.590777551 -0400 +--- pmx2618.for 2012-04-25 13:37:15.659777518 -0400 +*************** +*** 753,760 **** + read(*,'(a)')jobname + numargs = 1 + else +! call getarg(1,jobname,idum) ! May need to replace this w/ next line +! c call getarg(1,jobname) + end if + 10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then +--- 753,760 ---- + read(*,'(a)')jobname + numargs = 1 + else +! c call getarg(1,jobname,idum) ! May need to replace this w/ next line +! call getarg(1,jobname) + end if + 10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then +*************** +*** 766,773 **** + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. +! call getarg(2,jobname,idum) ! May need to replace this w/ next line +! c call getarg(2,jobname) + numargs = 1 + go to 10 + else +--- 766,773 ---- + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. +! c call getarg(2,jobname,idum) ! May need to replace this w/ next line +! call getarg(2,jobname) + numargs = 1 + go to 10 + else diff --git a/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 b/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 new file mode 100644 index 00000000000..ea95290e8ed --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 @@ -0,0 +1,31 @@ +*** scor2prt.for.orig 2012-04-25 13:23:32.439903295 -0400 +--- scor2prt.for 2012-04-25 13:30:54.966902964 -0400 +*************** +*** 106,113 **** + read(*,'(a)')jobname + numargs = 1 + else +! call getarg(1,jobname,idum) ! May need to replace this w/ next line +! c call getarg(1,jobname) + end if + ljob = lenstr(jobname,27) + if (ljob .eq. 0) then +--- 106,113 ---- + read(*,'(a)')jobname + numargs = 1 + else +! c call getarg(1,jobname,idum) ! May need to replace this w/ next line +! call getarg(1,jobname) + end if + ljob = lenstr(jobname,27) + if (ljob .eq. 0) then +*************** +*** 1480,1485 **** +--- 1480,1486 ---- + c + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow ++ logical insetup,replacing,clefpend,botv + character*128 line + iccount = 0 + do 1 iset = 1 , 12 diff --git a/Build/source/utils/pmx/pmx-2.6.18/README b/Build/source/utils/pmx/pmx-2.6.18/README new file mode 100644 index 00000000000..3e5060616d4 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/README @@ -0,0 +1,11 @@ +This is PMX, version 2.6.18. PMX provides a preprocessor for MusiXTeX. + +pmxab builds a TeX input file based on a .pmx input file in a much +simpler language, making most of the layout decisions by itself. It has +most of MusiXTeX's functionality, but it also permits in-line TeX to +give access to virtually all of MusiXTeX. For proof-listening, pmxab will +make a MIDI file of your score. + +scor2prt is an auxiliary program that makes parts from a score. + +The author of pmxab and scor2prt is Don Simons (dsimons@roadrunner.com). diff --git a/Build/source/utils/pmx/pmx-2.6.18/arith.h b/Build/source/utils/pmx/pmx-2.6.18/arith.h new file mode 100644 index 00000000000..e69de29bb2d diff --git a/Build/source/utils/pmx/pmx-2.6.18/config.h.in b/Build/source/utils/pmx/pmx-2.6.18/config.h.in new file mode 100644 index 00000000000..5706e9a0864 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/config.h.in @@ -0,0 +1,90 @@ +/* config.h.in. Generated from configure.ac by autoheader. */ + +/* Define to 1 if you have the `atexit' function. */ +#undef HAVE_ATEXIT + +/* Define to 1 if you have the header file. */ +#undef HAVE_FENV_H + +/* Define to 1 if you have the `floor' function. */ +#undef HAVE_FLOOR + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the `m' library (-lm). */ +#undef HAVE_LIBM + +/* Define to 1 if your system has a GNU libc compatible `malloc' function, and + to 0 otherwise. */ +#undef HAVE_MALLOC + +/* Define to 1 if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define to 1 if you have the `memset' function. */ +#undef HAVE_MEMSET + +/* Define to 1 if you have the `pow' function. */ +#undef HAVE_POW + +/* Define to 1 if your system has a GNU libc compatible `realloc' function, + and to 0 otherwise. */ +#undef HAVE_REALLOC + +/* Define to 1 if you have the `sqrt' function. */ +#undef HAVE_SQRT + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Name of package */ +#undef PACKAGE + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* Define to 1 if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Version number of package */ +#undef VERSION + +/* Define to rpl_malloc if the replacement function should be used. */ +#undef malloc + +/* Define to rpl_realloc if the replacement function should be used. */ +#undef realloc + +/* Define to `unsigned int' if does not define. */ +#undef size_t diff --git a/Build/source/utils/pmx/pmx-2.6.18/configure.ac b/Build/source/utils/pmx/pmx-2.6.18/configure.ac new file mode 100644 index 00000000000..d56db2ca306 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/configure.ac @@ -0,0 +1,42 @@ +dnl Process this file with autoconf to produce a configure script. +dnl +dnl Copyright (C) 2012 Peter Breitenlohner +dnl +dnl This file is free software; the copyright holder +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. +dnl +m4_include([version.ac])[] dnl define pmx_version +AC_INIT([pmx], pmx_version, [rdt@cs.queensu.ca]) +AC_PREREQ([2.63]) +AC_CONFIG_SRCDIR([pmxab.c]) + +AM_INIT_AUTOMAKE(pmx, pmx_version) + +dnl Check compiler and flags +AC_PROG_CC + +dnl initial value for AM_CPPFLAGS +AC_SUBST([AM_CPPFLAGS], ['-DNON_UNIX_STDIO']) + +dnl WIN32 has no +AM_CONDITIONAL([WIN32], [test "x$kpse_cv_have_win32" != xno]) +if test "x$kpse_cv_have_win32" != xno; then + AM_CPPFLAGS="$AM_CPPPFLAGS -DUSE_CLOCK" +fi + +dnl Checks for programs. +AC_PROG_INSTALL +AC_PROG_LN_S +AC_PROG_MAKE_SET +AC_PROG_RANLIB + +AC_SEARCH_LIBS([sqrt], [m]) + +AC_CHECK_SIZEOF([long long]) +if test $ac_cv_sizeof_long_long -lt 8; then + AM_CPPFLAGS="$AM_CPPPFLAGS -DNO_LONG_LONG" +fi + +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile new file mode 100644 index 00000000000..528a7418bbb --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile @@ -0,0 +1,61 @@ +CFLAGS = -Wall -W -pedantic -O2 -DNON_UNIX_STDIO -fPIC + +MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\ + lbitbits.o lbitshft.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o +I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\ + fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\ + open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\ + typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o +TIME = dtime_.o etime_.o + +OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME) + +all: arith.h f2c.h signal1.h sysdep1.h libf2c.a + +libf2c.a: $(OFILES) + ar r libf2c.a $? + +f77vers.o: f77vers.c + +i77vers.o: i77vers.c + + +arith.h: arithchk.c + $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ + $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm + ./a.out >arith.h + rm -f a.out arithchk.o + +clean: + rm -f libf2c.a *.o arith.h + + +EMPTY_AUTOMAKE_TARGETS = dvi pdf ps info html tags ctags install install-data install-exec uninstall install-dvi install-html install-info install-ps install-pdf installdirs check installcheck mostlyclean distclean maintainer-clean +.PHONY: $(EMPTY_AUTOMAKE_TARGETS) +$(EMPTY_AUTOMAKE_TARGETS): + +DISTFILES = +distdir: $(DISTFILES) + cp Notice Makefile README *.h *.c $(distdir) + cp f2c.h $(top_distdir) diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice new file mode 100644 index 00000000000..261b719bc57 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/README b/Build/source/utils/pmx/pmx-2.6.18/libf2c/README new file mode 100644 index 00000000000..73388d0bd4f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/README @@ -0,0 +1,329 @@ +If your system has a double drem() function such that drem(a,b) +is the IEEE remainder function (with double a, b), then you may +wish to compile r_mod.c and d_mod.c with IEEE_drem defined. + +On machines, such as those using a DEC Alpha processor, on which +sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and +sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by +removing the first occurrence of "long " on each line containing +"long ". On Unix systems, you can do this by issuing the commands + mv f2c.h f2c.h0 + sed 's/long int /int /' f2c.h0 >f2c.h +On such machines, one can enable INTEGER*8 by uncommenting the typedefs +of longint and ulongint in f2c.h and adjusting them, so they read + typedef long longint; + typedef unsigned long ulongint; +and by compiling libf2c with -DAllow_TYQUAD, as discussed below. + + +Most of the routines in libf2c are support routines for Fortran +intrinsic functions or for operations that f2c chooses not +to do "in line". There are a few exceptions, summarized below -- +functions and subroutines that appear to your program as ordinary +external Fortran routines. + +If you use the REAL valued functions listed below (ERF, ERFC, +DTIME, and ETIME) with "f2c -R", then you need to compile the +corresponding source files with -DREAL=float. To do this, it is +perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. + +1. CALL ABORT prints a message and causes a core dump. + +2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION + error functions (with x REAL and d DOUBLE PRECISION); + DERF must be declared DOUBLE PRECISION in your program. + Both ERF and DERF assume your C library provides the + underlying erf() function (which not all systems do). + +3. ERFC(r) and DERFC(d) are the complementary error functions: + ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) + (except that their results may be more accurate than + explicitly evaluating the above formulae would give). + Again, ERFC and r are REAL, and DERFC and d are DOUBLE + PRECISION (and must be declared as such in your program), + and ERFC and DERFC rely on your system's erfc(). + +4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER + variable, sets s to the n-th command-line argument (or to + all blanks if there are fewer than n command-line arguments); + CALL GETARG(0,s) sets s to the name of the program (on systems + that support this feature). See IARGC below. + +5. CALL GETENV(name, value), where name and value are of type + CHARACTER, sets value to the environment value, $name, of + name (or to blanks if $name has not been set). + +6. NARGS = IARGC() sets NARGS to the number of command-line + arguments (an INTEGER value). + +7. CALL SIGNAL(n,func), where n is an INTEGER and func is an + EXTERNAL procedure, arranges for func to be invoked when n + occurs (on systems where this makes sense). + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +8. ETIME(ARR) and DTIME(ARR) are REAL functions that return + execution times. ARR is declared REAL ARR(2). The elapsed + user and system CPU times are stored in ARR(1) and ARR(2), + respectively. ETIME returns the total elapsed CPU time, + i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU + time since the previous call on DTIME. + +9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes + cmd to the system's command processor (on systems where + this can be done). + +10. CALL FLUSH flushes all buffers. + +11. FTELL(i) is an INTEGER function that returns the current + offset of Fortran unit i (or -1 if unit i is not open). + +12. CALL FSEEK(i, offset, whence, *errlab) attemps to move + Fortran unit i to the specified offset: absolute offset + if whence = 0; relative to the current offset if whence = 1; + relative to the end of the file if whence = 2. It branches + to label errlab if unit i is not open or if the call + otherwise fails. + +The routines whose objects are makefile.u's $(I77) are for I/O. +The following comments apply to them. + +If your system lacks /usr/include/local.h , +then you should create an appropriate local.h in +this directory. An appropriate local.h may simply +be empty, or it may #define VAX or #define CRAY +(or whatever else you must do to make fp.h work right). +Alternatively, edit fp.h to suite your machine. + +If your system lacks /usr/include/fcntl.h , then you +should simply create an empty fcntl.h in this directory. +If your compiler then complains about creat and open not +having a prototype, compile with OPEN_DECL defined. +On many systems, open and creat are declared in fcntl.h . + +If your system's sprintf does not work the way ANSI C +specifies -- specifically, if it does not return the +number of characters transmitted -- then insert the line + +#define USE_STRLEN + +at the end of fmt.h . This is necessary with +at least some versions of Sun software. +In particular, if you get a warning about an improper +pointer/integer combination in compiling wref.c, then +you need to compile with -DUSE_STRLEN . + +If your system's fopen does not like the ANSI binary +reading and writing modes "rb" and "wb", then you should +compile open.c with NON_ANSI_RW_MODES #defined. + +If you get error messages about references to cf->_ptr +and cf->_base when compiling wrtfmt.c and wsfe.c or to +stderr->_flag when compiling err.c, then insert the line + +#define NON_UNIX_STDIO + +at the beginning of fio.h, and recompile everything (or +at least those modules that contain NON_UNIX_STDIO). + +Unformatted sequential records consist of a length of record +contents, the record contents themselves, and the length of +record contents again (for backspace). Prior to 17 Oct. 1991, +the length was of type int; now it is of type long, but you +can change it back to int by inserting + +#define UIOLEN_int + +at the beginning of fio.h. This affects only sue.c and uio.c . + +If you have a really ancient K&R C compiler that does not understand +void, add -Dvoid=int to the definition of CFLAGS in the makefile. + +On VAX, Cray, or Research Tenth-Edition Unix systems, you may +need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +to make fp.h work correctly. Alternatively, you may need to +edit fp.h to suit your machine. + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +You may need to supply the following non-ANSI routines: + + fstat(int fileds, struct stat *buf) is similar +to stat(char *name, struct stat *buf), except that +the first argument, fileds, is the file descriptor +returned by open rather than the name of the file. +fstat is used in the system-dependent routine +canseek (in the libf2c source file err.c), which +is supposed to return 1 if it's possible to issue +seeks on the file in question, 0 if it's not; you may +need to suitably modify err.c . On non-UNIX systems, +you can avoid references to fstat and stat by compiling +with NON_UNIX_STDIO defined; in that case, you may need +to supply access(char *Name,0), which is supposed to +return 0 if file Name exists, nonzero otherwise. + + char * mktemp(char *buf) is supposed to replace the +6 trailing X's in buf with a unique number and then +return buf. The idea is to get a unique name for +a temporary file. + +On non-UNIX systems, you may need to change a few other, +e.g.: the form of name computed by mktemp() in endfile.c and +open.c; the use of the open(), close(), and creat() system +calls in endfile.c, err.c, open.c; and the modes in calls on +fopen() and fdopen() (and perhaps the use of fdopen() itself +-- it's supposed to return a FILE* corresponding to a given +an integer file descriptor) in err.c and open.c (component ufmt +of struct unit is 1 for formatted I/O -- text mode on some systems +-- and 0 for unformatted I/O -- binary mode on some systems). +Compiling with -DNON_UNIX_STDIO omits all references to creat() +and almost all references to open() and close(), the exception +being in the function f__isdev() (in open.c). + +If you wish to use translated Fortran that has funny notions +of record length for direct unformatted I/O (i.e., that assumes +RECL= values in OPEN statements are not bytes but rather counts +of some other units -- e.g., 4-character words for VMS), then you +should insert an appropriate #define for url_Adjust at the +beginning of open.c . For VMS Fortran, for example, +#define url_Adjust(x) x *= 4 +would suffice. + +By default, Fortran I/O units 5, 6, and 0 are pre-connected to +stdin, stdout, and stderr, respectively. You can change this +behavior by changing f_init() in err.c to suit your needs. +Note that f2c assumes READ(*... means READ(5... and WRITE(*... +means WRITE(6... . Moreover, an OPEN(n,... statement that does +not specify a file name (and does not specify STATUS='SCRATCH') +assumes FILE='fort.n' . You can change this by editing open.c +and endfile.c suitably. + +Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +0, 1, ..., 99 are available, i.e., the highest allowed unit number +is MXUNIT - 1. + +Lines protected from compilation by #ifdef Allow_TYQUAD +are for a possible extension to 64-bit integers in which +integer = int = 32 bits and longint = long = 64 bits. + +The makefile does not attempt to compile pow_qq.c, qbitbits.c, +and qbitshft.c, which are meant for use with INTEGER*8. To use +INTEGER*8, you must modify f2c.h to declare longint and ulongint +appropriately; then add $(QINT) to the end of the makefile's +dependency list for libf2c.a (if makefile is a copy of makefile.u; +for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj +to the library's dependency list and adjust libf2c.lbc or libf2c.sy +accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS +assignment. To make longint and ulongint available, it may suffice +to add -DINTEGER_STAR_8 to the CFLAGS assignment. + +Following Fortran 90, s_cat.c and s_copy.c allow the target of a +(character string) assignment to be appear on its right-hand, at +the cost of some extra overhead for all run-time concatenations. +If you prefer the extra efficiency that comes with the Fortran 77 +requirement that the left-hand side of a character assignment not +be involved in the right-hand side, compile s_cat.c and s_copy.c +with -DNO_OVERWRITE . + +Extensions (Feb. 1993) to NAMELIST processing: + 1. Reading a ? instead of &name (the start of a namelist) causes +the namelist being sought to be written to stdout (unit 6); +to omit this feature, compile rsne.c with -DNo_Namelist_Questions. + 2. Reading the wrong namelist name now leads to an error message +and an attempt to skip input until the right namelist name is found; +to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. + 3. Namelist writes now insert newlines before each variable; to omit +this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. + 4. (Sept. 1995) When looking for the &name that starts namelist +input, lines whose first non-blank character is something other +than &, $, or ? are treated as comment lines and ignored, unless +rsne.c is compiled with -DNo_Namelist_Comments. + +Nonstandard extension (Feb. 1993) to open: for sequential files, +ACCESS='APPEND' (or access='anything else starting with "A" or "a"') +causes the file to be positioned at end-of-file, so a write will +append to the file. + +Some buggy Fortran programs use unformatted direct I/O to write +an incomplete record and later read more from that record than +they have written. For records other than the last, the unwritten +portion of the record reads as binary zeros. The last record is +a special case: attempting to read more from it than was written +gives end-of-file -- which may help one find a bug. Some other +Fortran I/O libraries treat the last record no differently than +others and thus give no help in finding the bug of reading more +than was written. If you wish to have this behavior, compile +uio.c with -DPad_UDread . + +If you want to be able to catch write failures (e.g., due to a +disk being full) with an ERR= specifier, compile dfe.c, due.c, +sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +slower execution and more I/O, but should make ERR= work as +expected, provided fflush returns an error return when its +physical write fails. + +Carriage controls are meant to be interpreted by the UNIX col +program (or a similar program). Sometimes it's convenient to use +only ' ' as the carriage control character (normal single spacing). +If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +external output lines will have an initial ' ' quietly omitted, +making use of the col program unnecessary with output that only +has ' ' for carriage control. + +The Fortran 77 Standard leaves it up to the implementation whether +formatted writes of floating-point numbers of absolute value < 1 have +a zero before the decimal point. By default, libI77 omits such +superfluous zeros, but you can cause them to appear by compiling +lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . + +If your (Unix) system lacks a ranlib command, you don't need it. +Either comment out the makefile's ranlib invocation, or install +a harmless "ranlib" command somewhere in your PATH, such as the +one-line shell script + + exit 0 + +or (on some systems) + + exec /usr/bin/ar lts $1 >/dev/null + +By default, the routines that implement complex and double complex +division, c_div.c and z_div.c, call sig_die to print an error message +and exit if they see a divisor of 0, as this is sometimes helpful for +debugging. On systems with IEEE arithmetic, compiling c_div.c and +z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both +the real and imaginary parts of the result to +INFINITY if the +numerator is nonzero, or to NaN if it vanishes. + +Nowadays most Unix and Linux systems have function + int ftruncate(int fildes, off_t len); +defined in system header file unistd.h that adjusts the length of file +descriptor fildes to length len. Unless endfile.c is compiled with +-DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if +necessary to shorten files. If your system lacks ftruncate(), compile +endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more +portable scheme of shortening a file by copying to a temporary file +and back again. + +The initializations for "f2c -trapuv" are done by _uninit_f2c(), +whose source is uninit.c, introduced June 2001. On IEEE-arithmetic +systems, _uninit_f2c should initialize floating-point variables to +signaling NaNs and, at its first invocation, should enable the +invalid operation exception. Alas, the rules for distinguishing +signaling from quiet NaNs were not specified in the IEEE P754 standard, +nor were the precise means of enabling and disabling IEEE-arithmetic +exceptions, and these details are thus system dependent. There are +#ifdef's in uninit.c that specify them for some popular systems. If +yours is not one of these systems, it may take some detective work to +discover the appropriate details for your system. Sometimes it helps +to look in the standard include directories for header files with +relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and +it may be simplest to run experiments to see what distinguishes a +signaling from a quiet NaN. (If x is initialized to a signaling +NaN and the invalid operation exception is masked off, as it should +be by default on IEEE-arithmetic systems, then computing, say, +y = x + 1 will yield a quiet NaN.) diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c new file mode 100644 index 00000000000..fa5aae6b716 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c @@ -0,0 +1,22 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); + +int abort_() +#else +extern void sig_die(char*,int); + +int abort_(void) +#endif +{ +sig_die("Fortran abort routine called", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c new file mode 100644 index 00000000000..94c93e2f2a4 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c @@ -0,0 +1,225 @@ +/**************************************************************** +Copyright (C) 1997, 1998, 2000 Lucent Technologies +All Rights Reserved + +Permission to use, copy, modify, and distribute this software and +its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the name of Lucent or any of its entities +not be used in advertising or publicity pertaining to +distribution of the software without specific, written prior +permission. + +LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, +INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. +IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY +SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER +IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. +****************************************************************/ + +/* Try to deduce arith.h from arithmetic properties. */ + +#include +#include +#include + +#ifdef NO_FPINIT +#define fpinit_ASL() +#else +#ifndef KR_headers +extern +#ifdef __cplusplus + "C" +#endif + void fpinit_ASL(void); +#endif /*KR_headers*/ +#endif /*NO_FPINIT*/ + + static int dalign; + typedef struct +Akind { + char *name; + int kind; + } Akind; + + static Akind +IEEE_8087 = { "IEEE_8087", 1 }, +IEEE_MC68k = { "IEEE_MC68k", 2 }, +IBM = { "IBM", 3 }, +VAX = { "VAX", 4 }, +CRAY = { "CRAY", 5}; + + static double t_nan; + + static Akind * +Lcheck() +{ + union { + double d; + long L[2]; + } u; + struct { + double d; + long L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + + static Akind * +icheck() +{ + union { + double d; + int L[2]; + } u; + struct { + double d; + int L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + +char *emptyfmt = ""; /* avoid possible warning message with printf("") */ + + static Akind * +ccheck() +{ + union { + double d; + long L; + } u; + long Cray1; + + /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ + Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 693716; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 115456; + u.d = 1e13; + if (u.L == Cray1) + return &CRAY; + return 0; + } + + static int +fzcheck() +{ + double a, b; + int i; + + a = 1.; + b = .1; + for(i = 155;; b *= b, i >>= 1) { + if (i & 1) { + a *= b; + if (i == 1) + break; + } + } + b = a * a; + return b == 0.; + } + + static int +need_nancheck() +{ + double t; + + errno = 0; + t = log(t_nan); + if (errno == 0) + return 1; + errno = 0; + t = sqrt(t_nan); + return errno == 0; + } + +main() +{ + FILE *f; + Akind *a = 0; + int Ldef = 0; + + fpinit_ASL(); +#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ + f = fopen("arith.h", "w"); + if (!f) { + printf("Cannot open arith.h\n"); + return 1; + } +#else + f = stdout; +#endif + + if (sizeof(double) == 2*sizeof(long)) + a = Lcheck(); + else if (sizeof(double) == 2*sizeof(int)) { + Ldef = 1; + a = icheck(); + } + else if (sizeof(double) == sizeof(long)) + a = ccheck(); + if (a) { + fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", + a->name, a->kind); + if (Ldef) + fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); + if (dalign) + fprintf(f, "#define Double_Align\n"); + if (sizeof(char*) == 8) + fprintf(f, "#define X64_bit_pointers\n"); +#ifndef NO_LONG_LONG + if (sizeof(long long) < 8) +#endif + fprintf(f, "#define NO_LONG_LONG\n"); + if (a->kind <= 2) { + if (fzcheck()) + fprintf(f, "#define Sudden_Underflow\n"); + t_nan = -a->kind; + if (need_nancheck()) + fprintf(f, "#define NANCHECK\n"); + } + return 0; + } + fprintf(f, "/* Unknown arithmetic */\n"); + return 1; + } + +#ifdef __sun +#ifdef __i386 +/* kludge for Intel Solaris */ +void fpsetprec(int x) { } +#endif +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c new file mode 100644 index 00000000000..908a61897aa --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c @@ -0,0 +1,76 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_back(a) alist *a; +#else +integer f_back(alist *a) +#endif +{ unit *b; + OFF_T v, w, x, y, z; + uiolen n; + FILE *f; + + f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ + if(a->aunit >= MXUNIT || a->aunit < 0) + err(a->aerr,101,"backspace") + if(b->useek==0) err(a->aerr,106,"backspace") + if(b->ufd == NULL) { + fk_open(1, 1, a->aunit); + return(0); + } + if(b->uend==1) + { b->uend=0; + return(0); + } + if(b->uwrt) { + t_runc(a); + if (f__nowreading(b)) + err(a->aerr,errno,"backspace") + } + f = b->ufd; /* may have changed in t_runc() */ + if(b->url>0) + { + x=FTELL(f); + y = x % b->url; + if(y == 0) x--; + x /= b->url; + x *= b->url; + (void) FSEEK(f,x,SEEK_SET); + return(0); + } + + if(b->ufmt==0) + { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); + fread((char *)&n,sizeof(uiolen),1,f); + FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); + return(0); + } + w = x = FTELL(f); + z = 0; + loop: + while(x) { + x -= x < 64 ? x : 64; + FSEEK(f,x,SEEK_SET); + for(y = x; y < w; y++) { + if (getc(f) != '\n') + continue; + v = FTELL(f); + if (v == w) { + if (z) + goto break2; + goto loop; + } + z = v; + } + err(a->aerr,(EOF),"backspace") + } + break2: + FSEEK(f, z, SEEK_SET); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c new file mode 100644 index 00000000000..858f2c8b4b1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double f__cabs(); + +double c_abs(z) complex *z; +#else +extern double f__cabs(double, double); + +double c_abs(complex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c new file mode 100644 index 00000000000..29fe49e3cda --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_cos(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_cos(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c new file mode 100644 index 00000000000..59425e7aaad --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c @@ -0,0 +1,53 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID c_div(c, a, b) +complex *a, *b, *c; +#else +extern void sig_die(char*,int); +void c_div(complex *c, complex *a, complex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + float af, bf; + af = bf = abr; + if (a->i != 0 || a->r != 0) + af = 1.; + c->i = c->r = af / bf; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c new file mode 100644 index 00000000000..f46508d35b1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double exp(), cos(), sin(); + + VOID c_exp(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_exp(complex *r, complex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c new file mode 100644 index 00000000000..a0ba3f0d8d2 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double log(), f__cabs(), atan2(); +VOID c_log(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_log(complex *r, complex *z) +#endif +{ + double zi, zr; + r->i = atan2(zi = z->i, zr = z->r); + r->r = log( f__cabs(zr, zi) ); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c new file mode 100644 index 00000000000..c8bc30f2d69 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_sin(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_sin(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c new file mode 100644 index 00000000000..1678c534d60 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c @@ -0,0 +1,41 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sqrt(), f__cabs(); + +VOID c_sqrt(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_sqrt(complex *r, complex *z) +#endif +{ + double mag, t; + double zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = t = sqrt(0.5 * (mag + zr) ); + t = zi / t; + r->i = 0.5 * t; + } + else + { + t = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + t = -t; + r->i = t; + t = zi / t; + r->r = 0.5 * t; + } + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c new file mode 100644 index 00000000000..84750d505cf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c @@ -0,0 +1,33 @@ +#ifdef KR_headers +extern double sqrt(); +double f__cabs(real, imag) double real, imag; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double f__cabs(double real, double imag) +#endif +{ +double temp; + +if(real < 0) + real = -real; +if(imag < 0) + imag = -imag; +if(imag > real){ + temp = real; + real = imag; + imag = temp; +} +if((real+imag) == real) + return(real); + +temp = imag/real; +temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +return(temp); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c new file mode 100644 index 00000000000..e958c7172a8 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c @@ -0,0 +1,101 @@ +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_clos(a) cllist *a; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef NON_UNIX_STDIO +#ifndef unlink +#define unlink remove +#endif +#else +#ifdef MSDOS +#include "io.h" +#else +#ifdef __cplusplus +extern "C" int unlink(const char*); +#else +extern int unlink(const char*); +#endif +#endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +integer f_clos(cllist *a) +#endif +{ unit *b; + + if(a->cunit >= MXUNIT) return(0); + b= &f__units[a->cunit]; + if(b->ufd==NULL) + goto done; + if (b->uscrtch == 1) + goto Delete; + if (!a->csta) + goto Keep; + switch(*a->csta) { + default: + Keep: + case 'k': + case 'K': + if(b->uwrt == 1) + t_runc((alist *)a); + if(b->ufnm) { + fclose(b->ufd); + free(b->ufnm); + } + break; + case 'd': + case 'D': + Delete: + fclose(b->ufd); + if(b->ufnm) { + unlink(b->ufnm); /*SYSDEP*/ + free(b->ufnm); + } + } + b->ufd=NULL; + done: + b->uend=0; + b->ufnm=NULL; + return(0); + } + void +#ifdef KR_headers +f_exit() +#else +f_exit(void) +#endif +{ int i; + static cllist xx; + if (!xx.cerr) { + xx.cerr=1; + xx.csta=NULL; + for(i=0;i= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c new file mode 100644 index 00000000000..69005b56d76 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double d_acos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_acos(doublereal *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c new file mode 100644 index 00000000000..d5196ab101e --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double d_asin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_asin(doublereal *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c new file mode 100644 index 00000000000..d8856f8d698 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double d_atan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atan(doublereal *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c new file mode 100644 index 00000000000..56113850ab9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double d_atn2(x,y) doublereal *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atn2(doublereal *x, doublereal *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c new file mode 100644 index 00000000000..38471d9bc0e --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c @@ -0,0 +1,19 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +d_cnjg(r, z) doublecomplex *r, *z; +#else +d_cnjg(doublecomplex *r, doublecomplex *z) +#endif +{ + doublereal zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c new file mode 100644 index 00000000000..12def9ad0fd --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double d_cos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cos(doublereal *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c new file mode 100644 index 00000000000..9214c7a0d82 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double d_cosh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cosh(doublereal *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c new file mode 100644 index 00000000000..627ddb690fd --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_dim(a,b) doublereal *a, *b; +#else +double d_dim(doublereal *a, doublereal *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c new file mode 100644 index 00000000000..e9ab5d4425c --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double d_exp(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_exp(doublereal *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c new file mode 100644 index 00000000000..d17b9dd591d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_imag(z) doublecomplex *z; +#else +double d_imag(doublecomplex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c new file mode 100644 index 00000000000..6da4ce35e92 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_int(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_int(doublereal *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c new file mode 100644 index 00000000000..664c19d9e99 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double d_lg10(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_lg10(doublereal *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c new file mode 100644 index 00000000000..e74be02c54e --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double d_log(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_log(doublereal *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c new file mode 100644 index 00000000000..3766d9fa828 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double d_mod(x,y) doublereal *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double d_mod(doublereal *x, doublereal *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c new file mode 100644 index 00000000000..66f2dd0ee67 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_nint(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_nint(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c new file mode 100644 index 00000000000..f9f348b03dd --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_prod(x,y) real *x, *y; +#else +double d_prod(real *x, real *y) +#endif +{ +return( (*x) * (*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c new file mode 100644 index 00000000000..d06e0d19231 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_sign(a,b) doublereal *a, *b; +#else +double d_sign(doublereal *a, doublereal *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c new file mode 100644 index 00000000000..ebd4eec5eeb --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double d_sin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sin(doublereal *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c new file mode 100644 index 00000000000..2479a6fab22 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double d_sinh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sinh(doublereal *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c new file mode 100644 index 00000000000..a7fa66c00aa --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double d_sqrt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sqrt(doublereal *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c new file mode 100644 index 00000000000..7d252c4d5cf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double d_tan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tan(doublereal *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c new file mode 100644 index 00000000000..415b58508b3 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double d_tanh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tanh(doublereal *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c new file mode 100644 index 00000000000..d935d315213 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double erf(); +double derf_(x) doublereal *x; +#else +extern double erf(double); +double derf_(doublereal *x) +#endif +{ +return( erf(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c new file mode 100644 index 00000000000..18f5c619b6f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double erfc(); + +double derfc_(x) doublereal *x; +#else +extern double erfc(double); + +double derfc_(doublereal *x) +#endif +{ +return( erfc(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c new file mode 100644 index 00000000000..c6b10d0e9c3 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c @@ -0,0 +1,151 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +y_rsk(Void) +{ + if(f__curunit->uend || f__curunit->url <= f__recpos + || f__curunit->url == 1) return 0; + do { + getc(f__cf); + } while(++f__recpos < f__curunit->url); + return 0; +} + + int +y_getc(Void) +{ + int ch; + if(f__curunit->uend) return(-1); + if((ch=getc(f__cf))!=EOF) + { + f__recpos++; + if(f__curunit->url>=f__recpos || + f__curunit->url==1) + return(ch); + else return(' '); + } + if(feof(f__cf)) + { + f__curunit->uend=1; + errno=0; + return(-1); + } + err(f__elist->cierr,errno,"readingd"); +} + + static int +y_rev(Void) +{ + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__curunit->url > 1) + while(f__recpos < f__curunit->url) + (*f__putn)(' '); + if (f__recpos) + f__putbuf(0); + f__recpos = 0; + return(0); +} + + static int +y_err(Void) +{ + err(f__elist->cierr, 110, "dfe"); +} + + static int +y_newrec(Void) +{ + y_rev(); + f__hiwater = f__cursor = 0; + return(1); +} + + int +#ifdef KR_headers +c_dfe(a) cilist *a; +#else +c_dfe(cilist *a) +#endif +{ + f__sequential=0; + f__formatted=f__external=1; + f__elist=a; + f__cursor=f__scale=f__recpos=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>MXUNIT || a->ciunit<0) + err(a->cierr,101,"startchk"); + if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) + err(a->cierr,104,"dfe"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,102,"dfe") + if(!f__curunit->useek) err(a->cierr,104,"dfe") + f__fmtbuf=a->cifmt; + if(a->cirec <= 0) + err(a->cierr,130,"dfe") + FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdfe(a) cilist *a; +#else +integer s_rdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_dfe(a))return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + f__getn = y_getc; + f__doed = rd_ed; + f__doned = rd_ned; + f__dorevert = f__donewrec = y_err; + f__doend = y_rsk; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"read start"); + fmt_bg(); + return(0); +} +#ifdef KR_headers +integer s_wdfe(a) cilist *a; +#else +integer s_wdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=0; + if(n=c_dfe(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"startwrt"); + f__putn = x_putc; + f__doed = w_ed; + f__doned= w_ned; + f__dorevert = y_err; + f__donewrec = y_newrec; + f__doend = y_rev; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"startwrt"); + fmt_bg(); + return(0); +} +integer e_rdfe(Void) +{ + en_fio(); + return 0; +} +integer e_wdfe(Void) +{ + return en_fio(); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c new file mode 100644 index 00000000000..4070d879012 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +extern int (*f__lioproc)(); + +integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +#else +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); + +integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +#endif +{ + return((*f__lioproc)(number,ptr,len,*type)); +} +#ifdef __cplusplus + } +#endif +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c new file mode 100644 index 00000000000..6a09b3e9837 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c @@ -0,0 +1,63 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +dtime_(tarray) float *tarray; +#else +dtime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + static double t0; + double t = clock(); + tarray[1] = 0; + tarray[0] = (t - t0) / CLOCKS_PER_SECOND; + t0 = t; + return tarray[0]; +#else + struct tms t; + static struct tms t0; + + times(&t); + tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; + tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; + t0 = t; + return tarray[0] + tarray[1]; +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c new file mode 100644 index 00000000000..a7f4cec4673 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +#ifdef KR_headers +c_due(a) cilist *a; +#else +c_due(cilist *a) +#endif +{ + if(!f__init) f_init(); + f__sequential=f__formatted=f__recpos=0; + f__external=1; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,102,"cdue") + if(!f__curunit->useek) err(a->cierr,104,"cdue") + if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") + if(a->cirec <= 0) + err(a->cierr,130,"due") + FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdue(a) cilist *a; +#else +integer s_rdue(cilist *a) +#endif +{ + int n; + f__reading=1; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +#ifdef KR_headers +integer s_wdue(a) cilist *a; +#else +integer s_wdue(cilist *a) +#endif +{ + int n; + f__reading=0; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +integer e_rdue(Void) +{ + if(f__curunit->url==1 || f__recpos==f__curunit->url) + return(0); + FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); + if(FTELL(f__cf)%f__curunit->url) + err(f__elist->cierr,200,"syserr"); + return(0); +} +integer e_wdue(Void) +{ +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr,errno,"write end"); +#endif + return(e_rdue()); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c new file mode 100644 index 00000000000..70be0bc2e0b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c @@ -0,0 +1,25 @@ +/* EFL support routine to copy string b to string a */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + +#define M ( (long) (sizeof(long) - 1) ) +#define EVEN(x) ( ( (x)+ M) & (~M) ) + +#ifdef KR_headers +extern VOID s_copy(); +ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern void s_copy(char*,char*,ftnlen,ftnlen); +int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +return 0; /* ignored return value */ +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c new file mode 100644 index 00000000000..4b420ae6465 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c @@ -0,0 +1,20 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern integer s_cmp(char*,char*,ftnlen,ftnlen); +integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c new file mode 100644 index 00000000000..04020d3802d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c @@ -0,0 +1,160 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ +/* if it does not define int truncate(const char *name, off_t). */ + +#ifdef MSDOS +#undef NO_TRUNCATE +#define NO_TRUNCATE +#endif + +#ifndef NO_TRUNCATE +#include "unistd.h" +#endif + +#ifdef KR_headers +extern char *strcpy(); +extern FILE *tmpfile(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +extern char *f__r_mode[], *f__w_mode[]; + +#ifdef KR_headers +integer f_end(a) alist *a; +#else +integer f_end(alist *a) +#endif +{ + unit *b; + FILE *tf; + + if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); + b = &f__units[a->aunit]; + if(b->ufd==NULL) { + char nbuf[10]; + sprintf(nbuf,"fort.%ld",(long)a->aunit); + if (tf = FOPEN(nbuf, f__w_mode[0])) + fclose(tf); + return(0); + } + b->uend=1; + return(b->useek ? t_runc(a) : 0); +} + +#ifdef NO_TRUNCATE + static int +#ifdef KR_headers +copy(from, len, to) FILE *from, *to; register long len; +#else +copy(FILE *from, register long len, FILE *to) +#endif +{ + int len1; + char buf[BUFSIZ]; + + while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { + if (!fwrite(buf, len1, 1, to)) + return 1; + if ((len -= len1) <= 0) + break; + } + return 0; + } +#endif /* NO_TRUNCATE */ + + int +#ifdef KR_headers +t_runc(a) alist *a; +#else +t_runc(alist *a) +#endif +{ + OFF_T loc, len; + unit *b; + int rc; + FILE *bf; +#ifdef NO_TRUNCATE + FILE *tf; +#endif + + b = &f__units[a->aunit]; + if(b->url) + return(0); /*don't truncate direct files*/ + loc=FTELL(bf = b->ufd); + FSEEK(bf,(OFF_T)0,SEEK_END); + len=FTELL(bf); + if (loc >= len || b->useek == 0) + return(0); +#ifdef NO_TRUNCATE + if (b->ufnm == NULL) + return 0; + rc = 0; + fclose(b->ufd); + if (!loc) { + if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) + rc = 1; + if (b->uwrt) + b->uwrt = 1; + goto done; + } + if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) + || !(tf = tmpfile())) { +#ifdef NON_UNIX_STDIO + bad: +#endif + rc = 1; + goto done; + } + if (copy(bf, (long)loc, tf)) { + bad1: + rc = 1; + goto done1; + } + if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) + goto bad1; + rewind(tf); + if (copy(tf, (long)loc, bf)) + goto bad1; + b->uwrt = 1; + b->urw = 2; +#ifdef NON_UNIX_STDIO + if (b->ufmt) { + fclose(bf); + if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) + goto bad; + FSEEK(bf,(OFF_T)0,SEEK_END); + b->urw = 3; + } +#endif +done1: + fclose(tf); +done: + f__cf = b->ufd = bf; +#else /* NO_TRUNCATE */ + if (b->urw & 2) + fflush(b->ufd); /* necessary on some Linux systems */ +#ifndef FTRUNCATE +#define FTRUNCATE ftruncate +#endif + rc = FTRUNCATE(fileno(b->ufd), loc); + /* The following FSEEK is unnecessary on some systems, */ + /* but should be harmless. */ + FSEEK(b->ufd, (OFF_T)0, SEEK_END); +#endif /* NO_TRUNCATE */ + if (rc) + err(a->aerr,111,"endfile"); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c new file mode 100644 index 00000000000..532fec61c86 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erf(); +REAL erf_(x) real *x; +#else +extern double erf(double); +REAL erf_(real *x) +#endif +{ +return( erf((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c new file mode 100644 index 00000000000..6f6c9f10644 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erfc(); +REAL erfc_(x) real *x; +#else +extern double erfc(double); +REAL erfc_(real *x) +#endif +{ +return( erfc((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c new file mode 100644 index 00000000000..b81ffc111f0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c @@ -0,0 +1,282 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#ifdef KR_headers +extern char *malloc(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif +#include "fio.h" +#include "fmt.h" /* for struct syl */ +#ifdef __cplusplus +extern "C" { +#endif + +/*global definitions*/ +unit f__units[MXUNIT]; /*unit table*/ +flag f__init; /*0 on entry, 1 after initializations*/ +cilist *f__elist; /*active external io list*/ +icilist *f__svic; /*active internal io list*/ +flag f__reading; /*1 if reading, 0 if writing*/ +flag f__cplus,f__cblank; +char *f__fmtbuf; +flag f__external; /*1 if external io, 0 if internal */ +#ifdef KR_headers +int (*f__doed)(),(*f__doned)(); +int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +int (*f__getn)(); /* for formatted input */ +void (*f__putn)(); /* for formatted output */ +#else +int (*f__getn)(void); /* for formatted input */ +void (*f__putn)(int); /* for formatted output */ +int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +#endif +flag f__sequential; /*1 if sequential io, 0 if direct*/ +flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +FILE *f__cf; /*current file*/ +unit *f__curunit; /*current unit*/ +int f__recpos; /*place in current record*/ +OFF_T f__cursor, f__hiwater; +int f__scale; +char *f__icptr; + +/*error messages*/ +char *F_err[] = +{ + "error in format", /* 100 */ + "illegal unit number", /* 101 */ + "formatted io not allowed", /* 102 */ + "unformatted io not allowed", /* 103 */ + "direct io not allowed", /* 104 */ + "sequential io not allowed", /* 105 */ + "can't backspace file", /* 106 */ + "null file name", /* 107 */ + "can't stat file", /* 108 */ + "unit not connected", /* 109 */ + "off end of record", /* 110 */ + "truncation failed in endfile", /* 111 */ + "incomprehensible list input", /* 112 */ + "out of free space", /* 113 */ + "unit not connected", /* 114 */ + "read unexpected character", /* 115 */ + "bad logical input field", /* 116 */ + "bad variable type", /* 117 */ + "bad namelist name", /* 118 */ + "variable not in namelist", /* 119 */ + "no end record", /* 120 */ + "variable count incorrect", /* 121 */ + "subscript for scalar variable", /* 122 */ + "invalid array section", /* 123 */ + "substring out of bounds", /* 124 */ + "subscript out of bounds", /* 125 */ + "can't read file", /* 126 */ + "can't write file", /* 127 */ + "'new' file exists", /* 128 */ + "can't append to file", /* 129 */ + "non-positive record number", /* 130 */ + "nmLbuf overflow" /* 131 */ +}; +#define MAXERR (sizeof(F_err)/sizeof(char *)+100) + + int +#ifdef KR_headers +f__canseek(f) FILE *f; /*SYSDEP*/ +#else +f__canseek(FILE *f) /*SYSDEP*/ +#endif +{ +#ifdef NON_UNIX_STDIO + return !isatty(fileno(f)); +#else + struct STAT_ST x; + + if (FSTAT(fileno(f),&x) < 0) + return(0); +#ifdef S_IFMT + switch(x.st_mode & S_IFMT) { + case S_IFDIR: + case S_IFREG: + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + case S_IFCHR: + if(isatty(fileno(f))) + return(0); + return(1); +#ifdef S_IFBLK + case S_IFBLK: + return(1); +#endif + } +#else +#ifdef S_ISDIR + /* POSIX version */ + if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + } + if (S_ISCHR(x.st_mode)) { + if(isatty(fileno(f))) + return(0); + return(1); + } + if (S_ISBLK(x.st_mode)) + return(1); +#else + Help! How does fstat work on this system? +#endif +#endif + return(0); /* who knows what it is? */ +#endif +} + + void +#ifdef KR_headers +f__fatal(n,s) char *s; +#else +f__fatal(int n, char *s) +#endif +{ + if(n<100 && n>=0) perror(s); /*SYSDEP*/ + else if(n >= (int)MAXERR || n < -1) + { fprintf(stderr,"%s: illegal error number %d\n",s,n); + } + else if(n == -1) fprintf(stderr,"%s: end of file\n",s); + else + fprintf(stderr,"%s: %s\n",s,F_err[n-100]); + if (f__curunit) { + fprintf(stderr,"apparent state: unit %d ", + (int)(f__curunit-f__units)); + fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", + f__curunit->ufnm); + } + else + fprintf(stderr,"apparent state: internal I/O\n"); + if (f__fmtbuf) + fprintf(stderr,"last format: %s\n",f__fmtbuf); + fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", + f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", + f__external?"external":"internal"); + sig_die(" IO", 1); +} +/*initialization routine*/ + VOID +f_init(Void) +{ unit *p; + + f__init=1; + p= &f__units[0]; + p->ufd=stderr; + p->useek=f__canseek(stderr); + p->ufmt=1; + p->uwrt=1; + p = &f__units[5]; + p->ufd=stdin; + p->useek=f__canseek(stdin); + p->ufmt=1; + p->uwrt=0; + p= &f__units[6]; + p->ufd=stdout; + p->useek=f__canseek(stdout); + p->ufmt=1; + p->uwrt=1; +} + + int +#ifdef KR_headers +f__nowreading(x) unit *x; +#else +f__nowreading(unit *x) +#endif +{ + OFF_T loc; + int ufmt, urw; + extern char *f__r_mode[], *f__w_mode[]; + + if (x->urw & 1) + goto done; + if (!x->ufnm) + goto cantread; + ufmt = x->url ? 0 : x->ufmt; + loc = FTELL(x->ufd); + urw = 3; + if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { + urw = 1; + if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { + cantread: + errno = 126; + return 1; + } + } + FSEEK(x->ufd,loc,SEEK_SET); + x->urw = urw; + done: + x->uwrt = 0; + return 0; +} + + int +#ifdef KR_headers +f__nowwriting(x) unit *x; +#else +f__nowwriting(unit *x) +#endif +{ + OFF_T loc; + int ufmt; + extern char *f__w_mode[]; + + if (x->urw & 2) { + if (x->urw & 1) + FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); + goto done; + } + if (!x->ufnm) + goto cantwrite; + ufmt = x->url ? 0 : x->ufmt; + if (x->uwrt == 3) { /* just did write, rewind */ + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) + goto cantwrite; + x->urw = 2; + } + else { + loc=FTELL(x->ufd); + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) + { + x->ufd = NULL; + cantwrite: + errno = 127; + return(1); + } + x->urw = 3; + FSEEK(x->ufd,loc,SEEK_SET); + } + done: + x->uwrt = 1; + return 0; +} + + int +#ifdef KR_headers +err__fl(f, m, s) int f, m; char *s; +#else +err__fl(int f, int m, char *s) +#endif +{ + if (!f) + f__fatal(m, s); + if (f__doend) + (*f__doend)(); + return errno = m; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c new file mode 100644 index 00000000000..2d9a36d8a31 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c @@ -0,0 +1,57 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +etime_(tarray) float *tarray; +#else +etime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + double t = clock(); + tarray[1] = 0; + return tarray[0] = t / CLOCKS_PER_SECOND; +#else + struct tms t; + + times(&t); + return (tarray[0] = (double)t.tms_utime/Hz) + + (tarray[1] = (double)t.tms_stime/Hz); +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c new file mode 100644 index 00000000000..08e9d07067c --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c @@ -0,0 +1,43 @@ +/* This gives the effect of + + subroutine exit(rc) + integer*4 rc + stop + end + + * with the added side effect of supplying rc as the program's exit code. + */ + +#include "f2c.h" +#undef abs +#undef min +#undef max +#ifndef KR_headers +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void f_exit(void); +#endif + + void +#ifdef KR_headers +exit_(rc) integer *rc; +#else +exit_(integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h new file mode 100644 index 00000000000..b94ee7c8e12 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef long int integer; +typedef unsigned long int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c new file mode 100644 index 00000000000..1ff0f896b30 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c @@ -0,0 +1,44 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include "stdio.h" + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void exit_(); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void exit_(integer*); +#ifdef __cplusplus + } +#endif + + char * +F77_aloc(integer Len, char *whence) +#endif +{ + char *rv; + unsigned int uLen = (unsigned int) Len; /* for K&R C */ + + if (!(rv = (char*)malloc(uLen))) { + fprintf(stderr, "malloc(%u) failure in %s\n", + uLen, whence); + exit_(&memfailure); + } + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c new file mode 100644 index 00000000000..782d40160ca --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c @@ -0,0 +1,93 @@ + char +_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20021004\n"; + +/* +2.00 11 June 1980. File version.c added to library. +2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed + [ d]erf[c ] added + 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c + 29 Nov. 1989: s_cmp returns long (for f2c) + 30 Nov. 1989: arg types from f2c.h + 12 Dec. 1989: s_rnge allows long names + 19 Dec. 1989: getenv_ allows unsorted environment + 28 Mar. 1990: add exit(0) to end of main() + 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main + 17 Oct. 1990: abort() calls changed to sig_die(...,1) + 22 Oct. 1990: separate sig_die from main + 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die + 31 May 1991: make system_ return status + 18 Dec. 1991: change long to ftnlen (for -i2) many places + 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) + 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c + and m**n in pow_hh.c and pow_ii.c; + catch SIGTRAP in main() for error msg before abort + 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined + 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); + change Cabs to f__cabs. + 12 March 1993: various tweaks for C++ + 2 June 1994: adjust so abnormal terminations invoke f_exit just once + 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. + 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS + 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines + that sign-extend right shifts when i is the most + negative integer. + 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side + of character assignments to appear on the right-hand + side (unless compiled with -DNO_OVERWRITE). + 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever + possible (for better cache behavior). + 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. + 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. + 6 Sept. 1995: fix return type of system_ under -DKR_headers. + 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. + 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). + 19 June 1996: add casts to unsigned in [lq]bitshft.c. + 26 Feb. 1997: adjust functions with a complex output argument + to permit aliasing it with input arguments. + (For now, at least, this is just for possible + benefit of g77.) + 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may + affect systems using gratuitous extra precision). + 19 Sept. 1997: [de]time_.c (Unix systems only): change return + type to double. + 2 May 1999: getenv_.c: omit environ in favor of getenv(). + c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, + z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with + overlapping arguments caused by equivalence. + 3 May 1999: "invisible" tweaks to omit compiler warnings in + abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. + + 7 Sept. 1999: [cz]_div.c: arrange for compilation under + -DIEEE_COMPLEX_DIVIDE to make these routines + avoid calling sig_die when the denominator + vanishes; instead, they return pairs of NaNs + or Infinities, depending whether the numerator + also vanishes or not. VERSION not changed. + 15 Nov. 1999: s_rnge.c: add casts for the case of + sizeof(ftnint) == sizeof(int) < sizeof(long). + 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., + z near (+-1,eps) with |eps| small. For the old + evaluation, compile with -DPre20000310 . + 20 April 2000: s_cat.c: tweak argument types to accord with + calls by f2c when ftnint and ftnlen are of + different sizes (different numbers of bits). + 4 July 2000: adjustments to permit compilation by C++ compilers; + VERSION string remains unchanged. + 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide. + dtime_.d, erf_.c, erfc_.c, etime.c: for use with + "f2c -R", compile with -DREAL=float. + 23 June 2001: add uninit.c; [fi]77vers.c: make version strings + visible as extern char _lib[fi]77_version_f2c[]. + 5 July 2001: modify uninit.c for __mc68k__ under Linux. + 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. + 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, + missing ~ on y in return value. + 14 March 2002: z_log.c: add code to cope with buggy compilers + (e.g., some versions of gcc under -O2 or -O3) + that do floating-point comparisons against values + computed into extended-precision registers on some + systems (such as Intel IA32 systems). Compile with + -DNO_DOUBLE_EXTENDED to omit the new logic. + 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. +*/ diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h new file mode 100644 index 00000000000..3d168bfcd1a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h @@ -0,0 +1,142 @@ +#ifndef SYSDEP_H_INCLUDED +#include "sysdep1.h" +#endif +#include "stdio.h" +#include "errno.h" +#ifndef NULL +/* ANSI C */ +#include "stddef.h" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +#ifndef FOPEN +#define FOPEN fopen +#endif + +#ifndef FREOPEN +#define FREOPEN freopen +#endif + +#ifndef FSEEK +#define FSEEK fseek +#endif + +#ifndef FSTAT +#define FSTAT fstat +#endif + +#ifndef FTELL +#define FTELL ftell +#endif + +#ifndef OFF_T +#define OFF_T long +#endif + +#ifndef STAT_ST +#define STAT_ST stat +#endif + +#ifndef STAT +#define STAT stat +#endif + +#ifdef MSDOS +#ifndef NON_UNIX_STDIO +#define NON_UNIX_STDIO +#endif +#endif + +#ifdef UIOLEN_int +typedef int uiolen; +#else +typedef long uiolen; +#endif + +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; +#ifndef MSDOS + long uinode; + int udev; +#endif + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag urw; /* (1 for can read) | (2 for can write) */ + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; + +extern flag f__init; +extern cilist *f__elist; /*active external io list*/ +extern flag f__reading,f__external,f__sequential,f__formatted; +#undef Void +#ifdef KR_headers +#define Void /*void*/ +extern int (*f__getn)(); /* for formatted input */ +extern void (*f__putn)(); /* for formatted output */ +extern void x_putc(); +extern long f__inode(); +extern VOID sig_die(); +extern int (*f__donewrec)(), t_putc(), x_wSL(); +extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); +#else +#define Void void +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__getn)(void); /* for formatted input */ +extern void (*f__putn)(int); /* for formatted output */ +extern void x_putc(int); +extern long f__inode(char*,int*); +extern void sig_die(char*,int); +extern void f__fatal(int,char*); +extern int t_runc(alist*); +extern int f__nowreading(unit*), f__nowwriting(unit*); +extern int fk_open(int,int,ftnint); +extern int en_fio(void); +extern void f_init(void); +extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); +extern int c_sfe(cilist*), z_rnew(void); +extern int isatty(int); +extern int err__fl(int,int,char*); +extern int xrd_SL(void); +extern int f__putbuf(int); +#ifdef __cplusplus + } +#endif +#endif +extern int (*f__doend)(Void); +extern FILE *f__cf; /*current file*/ +extern unit *f__curunit; /*current unit*/ +extern unit f__units[]; +#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} +#define errfl(f,m,s) return err__fl((int)f,m,s) + +/*Table sizes*/ +#define MXUNIT 100 + +extern int f__recpos; /*position in current record*/ +extern OFF_T f__cursor; /* offset to move to */ +extern OFF_T f__hiwater; /* so TL doesn't confuse us */ + +#define WRITE 1 +#define READ 2 +#define SEQ 3 +#define DIR 4 +#define FMT 5 +#define UNF 6 +#define EXT 7 +#define INT 8 + +#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c new file mode 100644 index 00000000000..80bcd0a7663 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c @@ -0,0 +1,525 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +#define skip(s) while(*s==' ') s++ +#ifdef interdata +#define SYLMX 300 +#endif +#ifdef pdp11 +#define SYLMX 300 +#endif +#ifdef vax +#define SYLMX 300 +#endif +#ifndef SYLMX +#define SYLMX 300 +#endif +#define GLITCH '\2' + /* special quote character for stu */ +extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +static struct syl f__syl[SYLMX]; +int f__parenlvl,f__pc,f__revloc; + + static +#ifdef KR_headers +char *ap_end(s) char *s; +#else +char *ap_end(char *s) +#endif +{ char quote; + quote= *s++; + for(;*s;s++) + { if(*s!=quote) continue; + if(*++s!=quote) return(s); + } + if(f__elist->cierr) { + errno = 100; + return(NULL); + } + f__fatal(100, "bad string"); + /*NOTREACHED*/ return 0; +} + static int +#ifdef KR_headers +op_gen(a,b,c,d) +#else +op_gen(int a, int b, int c, int d) +#endif +{ struct syl *p= &f__syl[f__pc]; + if(f__pc>=SYLMX) + { fprintf(stderr,"format too complicated:\n"); + sig_die(f__fmtbuf, 1); + } + p->op=a; + p->p1=b; + p->p2.i[0]=c; + p->p2.i[1]=d; + return(f__pc++); +} +#ifdef KR_headers +static char *f_list(); +static char *gt_num(s,n,n1) char *s; int *n, n1; +#else +static char *f_list(char*); +static char *gt_num(char *s, int *n, int n1) +#endif +{ int m=0,f__cnt=0; + char c; + for(c= *s;;c = *s) + { if(c==' ') + { s++; + continue; + } + if(c>'9' || c<'0') break; + m=10*m+c-'0'; + f__cnt++; + s++; + } + if(f__cnt==0) { + if (!n1) + s = 0; + *n=n1; + } + else *n=m; + return(s); +} + + static +#ifdef KR_headers +char *f_s(s,curloc) char *s; +#else +char *f_s(char *s, int curloc) +#endif +{ + skip(s); + if(*s++!='(') + { + return(NULL); + } + if(f__parenlvl++ ==1) f__revloc=curloc; + if(op_gen(RET1,curloc,0,0)<0 || + (s=f_list(s))==NULL) + { + return(NULL); + } + skip(s); + return(s); +} + + static int +#ifdef KR_headers +ne_d(s,p) char *s,**p; +#else +ne_d(char *s, char **p) +#endif +{ int n,x,sign=0; + struct syl *sp; + switch(*s) + { + default: + return(0); + case ':': (void) op_gen(COLON,0,0,0); break; + case '$': + (void) op_gen(NONL, 0, 0, 0); break; + case 'B': + case 'b': + if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); + else (void) op_gen(BN,0,0,0); + break; + case 'S': + case 's': + if(*(s+1)=='s' || *(s+1) == 'S') + { x=SS; + s++; + } + else if(*(s+1)=='p' || *(s+1) == 'P') + { x=SP; + s++; + } + else x=S; + (void) op_gen(x,0,0,0); + break; + case '/': (void) op_gen(SLASH,0,0,0); break; + case '-': sign=1; + case '+': s++; /*OUTRAGEOUS CODING TRICK*/ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if (!(s=gt_num(s,&n,0))) { + bad: *p = 0; + return 1; + } + switch(*s) + { + default: + return(0); + case 'P': + case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; + case 'X': + case 'x': (void) op_gen(X,n,0,0); break; + case 'H': + case 'h': + sp = &f__syl[op_gen(H,n,0,0)]; + sp->p2.s = s + 1; + s+=n; + break; + } + break; + case GLITCH: + case '"': + case '\'': + sp = &f__syl[op_gen(APOS,0,0,0)]; + sp->p2.s = s; + if((*p = ap_end(s)) == NULL) + return(0); + return(1); + case 'T': + case 't': + if(*(s+1)=='l' || *(s+1) == 'L') + { x=TL; + s++; + } + else if(*(s+1)=='r'|| *(s+1) == 'R') + { x=TR; + s++; + } + else x=T; + if (!(s=gt_num(s+1,&n,0))) + goto bad; + s--; + (void) op_gen(x,n,0,0); + break; + case 'X': + case 'x': (void) op_gen(X,1,0,0); break; + case 'P': + case 'p': (void) op_gen(P,1,0,0); break; + } + s++; + *p=s; + return(1); +} + + static int +#ifdef KR_headers +e_d(s,p) char *s,**p; +#else +e_d(char *s, char **p) +#endif +{ int i,im,n,w,d,e,found=0,x=0; + char *sv=s; + s=gt_num(s,&n,1); + (void) op_gen(STACK,n,0,0); + switch(*s++) + { + default: break; + case 'E': + case 'e': x=1; + case 'G': + case 'g': + found=1; + if (!(s=gt_num(s,&w,0))) { + bad: + *p = 0; + return 1; + } + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + if(*s!='E' && *s != 'e') + (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ + else { + if (!(s=gt_num(s+1,&e,0))) + goto bad; + (void) op_gen(x==1?EE:GE,w,d,e); + } + break; + case 'O': + case 'o': + i = O; + im = OM; + goto finish_I; + case 'Z': + case 'z': + i = Z; + im = ZM; + goto finish_I; + case 'L': + case 'l': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + (void) op_gen(L,w,0,0); + break; + case 'A': + case 'a': + found=1; + skip(s); + if(*s>='0' && *s<='9') + { s=gt_num(s,&w,1); + if(w==0) break; + (void) op_gen(AW,w,0,0); + break; + } + (void) op_gen(A,0,0,0); + break; + case 'F': + case 'f': + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(F,w,d,0); + break; + case 'D': + case 'd': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(D,w,d,0); + break; + case 'I': + case 'i': + i = I; + im = IM; + finish_I: + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s!='.') + { (void) op_gen(i,w,0,0); + break; + } + if (!(s=gt_num(s+1,&d,0))) + goto bad; + (void) op_gen(im,w,d,0); + break; + } + if(found==0) + { f__pc--; /*unSTACK*/ + *p=sv; + return(0); + } + *p=s; + return(1); +} + static +#ifdef KR_headers +char *i_tem(s) char *s; +#else +char *i_tem(char *s) +#endif +{ char *t; + int n,curloc; + if(*s==')') return(s); + if(ne_d(s,&t)) return(t); + if(e_d(s,&t)) return(t); + s=gt_num(s,&n,1); + if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); + return(f_s(s,curloc)); +} + + static +#ifdef KR_headers +char *f_list(s) char *s; +#else +char *f_list(char *s) +#endif +{ + for(;*s!=0;) + { skip(s); + if((s=i_tem(s))==NULL) return(NULL); + skip(s); + if(*s==',') s++; + else if(*s==')') + { if(--f__parenlvl==0) + { + (void) op_gen(REVERT,f__revloc,0,0); + return(++s); + } + (void) op_gen(GOTO,0,0,0); + return(++s); + } + } + return(NULL); +} + + int +#ifdef KR_headers +pars_f(s) char *s; +#else +pars_f(char *s) +#endif +{ + f__parenlvl=f__revloc=f__pc=0; + if(f_s(s,0) == NULL) + { + return(-1); + } + return(0); +} +#define STKSZ 10 +int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +flag f__workdone, f__nonl; + + static int +#ifdef KR_headers +type_f(n) +#else +type_f(int n) +#endif +{ + switch(n) + { + default: + return(n); + case RET1: + return(RET1); + case REVERT: return(REVERT); + case GOTO: return(GOTO); + case STACK: return(STACK); + case X: + case SLASH: + case APOS: case H: + case T: case TL: case TR: + return(NED); + case F: + case I: + case IM: + case A: case AW: + case O: case OM: + case L: + case E: case EE: case D: + case G: case GE: + case Z: case ZM: + return(ED); + } +} +#ifdef KR_headers +integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +#else +integer do_fio(ftnint *number, char *ptr, ftnlen len) +#endif +{ struct syl *p; + int n,i; + for(i=0;i<*number;i++,ptr+=len) + { +loop: switch(type_f((p= &f__syl[f__pc])->op)) + { + default: + fprintf(stderr,"unknown code in do_fio: %d\n%s\n", + p->op,f__fmtbuf); + err(f__elist->cierr,100,"do_fio"); + case NED: + if((*f__doned)(p)) + { f__pc++; + goto loop; + } + f__pc++; + continue; + case ED: + if(f__cnt[f__cp]<=0) + { f__cp--; + f__pc++; + goto loop; + } + if(ptr==NULL) + return((*f__doend)()); + f__cnt[f__cp]--; + f__workdone=1; + if((n=(*f__doed)(p,ptr,len))>0) + errfl(f__elist->cierr,errno,"fmt"); + if(n<0) + err(f__elist->ciend,(EOF),"fmt"); + continue; + case STACK: + f__cnt[++f__cp]=p->p1; + f__pc++; + goto loop; + case RET1: + f__ret[++f__rp]=p->p1; + f__pc++; + goto loop; + case GOTO: + if(--f__cnt[f__cp]<=0) + { f__cp--; + f__rp--; + f__pc++; + goto loop; + } + f__pc=1+f__ret[f__rp--]; + goto loop; + case REVERT: + f__rp=f__cp=0; + f__pc = p->p1; + if(ptr==NULL) + return((*f__doend)()); + if(!f__workdone) return(0); + if((n=(*f__dorevert)()) != 0) return(n); + goto loop; + case COLON: + if(ptr==NULL) + return((*f__doend)()); + f__pc++; + goto loop; + case NONL: + f__nonl = 1; + f__pc++; + goto loop; + case S: + case SS: + f__cplus=0; + f__pc++; + goto loop; + case SP: + f__cplus = 1; + f__pc++; + goto loop; + case P: f__scale=p->p1; + f__pc++; + goto loop; + case BN: + f__cblank=0; + f__pc++; + goto loop; + case BZ: + f__cblank=1; + f__pc++; + goto loop; + } + } + return(0); +} + + int +en_fio(Void) +{ ftnint one=1; + return(do_fio(&one,(char *)NULL,(ftnint)0)); +} + + VOID +fmt_bg(Void) +{ + f__workdone=f__cp=f__rp=f__pc=f__cursor=0; + f__cnt[0]=f__ret[0]=0; +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h new file mode 100644 index 00000000000..a2fdc651778 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h @@ -0,0 +1,104 @@ +struct syl +{ int op; + int p1; + union { int i[2]; char *s;} p2; + }; +#define RET1 1 +#define REVERT 2 +#define GOTO 3 +#define X 4 +#define SLASH 5 +#define STACK 6 +#define I 7 +#define ED 8 +#define NED 9 +#define IM 10 +#define APOS 11 +#define H 12 +#define TL 13 +#define TR 14 +#define T 15 +#define COLON 16 +#define S 17 +#define SP 18 +#define SS 19 +#define P 20 +#define BN 21 +#define BZ 22 +#define F 23 +#define E 24 +#define EE 25 +#define D 26 +#define G 27 +#define GE 28 +#define L 29 +#define A 30 +#define AW 31 +#define O 32 +#define NONL 33 +#define OM 34 +#define Z 35 +#define ZM 36 +extern int f__pc,f__parenlvl,f__revloc; +typedef union +{ real pf; + doublereal pd; +} ufloat; +typedef union +{ short is; +#ifndef KR_headers + signed +#endif + char ic; + integer il; +#ifdef Allow_TYQUAD + longint ili; +#endif +} Uint; +#ifdef KR_headers +extern int (*f__doed)(),(*f__doned)(); +extern int (*f__dorevert)(); +extern int rd_ed(),rd_ned(); +extern int w_ed(),w_ned(); +extern int signbit_f2c(); +#else +#ifdef __cplusplus +extern "C" { +#define Cextern extern "C" +#else +#define Cextern extern +#endif +extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +extern int (*f__dorevert)(void); +extern void fmt_bg(void); +extern int pars_f(char*); +extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +extern int signbit_f2c(double*); +extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +extern int wrt_E(ufloat*, int, int, int, ftnlen); +extern int wrt_F(ufloat*, int, int, ftnlen); +extern int wrt_L(Uint*, int, ftnlen); +#ifdef __cplusplus + } +#endif +#endif +extern flag f__cblank,f__cplus,f__workdone, f__nonl; +extern char *f__fmtbuf; +extern int f__scale; +#define GET(x) if((x=(*f__getn)())<0) return(x) +#define VAL(x) (x!='\n'?x:' ') +#define PUT(x) (*f__putn)(x) + +#undef TYQUAD +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#else +#define TYQUAD 14 +#endif + +#ifdef KR_headers +extern char *f__icvt(); +#else +Cextern char *f__icvt(longint, int*, int*, int); +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c new file mode 100644 index 00000000000..279f66f4390 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c @@ -0,0 +1,51 @@ +/* @(#)fmtlib.c 1.2 */ +#define MAXINTLENGTH 23 + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#undef ulongint +#define ulongint unsigned long +#endif + +#ifdef KR_headers +char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; + register int base; +#else +char *f__icvt(longint value, int *ndigit, int *sign, int base) +#endif +{ + static char buf[MAXINTLENGTH+1]; + register int i; + ulongint uvalue; + + if(value > 0) { + uvalue = value; + *sign = 0; + } + else if (value < 0) { + uvalue = -value; + *sign = 1; + } + else { + *sign = 0; + *ndigit = 1; + buf[MAXINTLENGTH-1] = '0'; + return &buf[MAXINTLENGTH-1]; + } + i = MAXINTLENGTH; + do { + buf[--i] = (uvalue%base) + '0'; + uvalue /= base; + } + while(uvalue > 0); + *ndigit = MAXINTLENGTH - i; + return &buf[i]; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h new file mode 100644 index 00000000000..40743d79f74 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h @@ -0,0 +1,28 @@ +#define FMAX 40 +#define EXPMAXDIGS 8 +#define EXPMAX 99999999 +/* FMAX = max number of nonzero digits passed to atof() */ +/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ + +#ifdef V10 /* Research Tenth-Edition Unix */ +#include "local.h" +#endif + +/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily + tight) on the maximum number of digits to the right and left of + * the decimal point. + */ + +#ifdef VAX +#define MAXFRACDIGS 56 +#define MAXINTDIGS 38 +#else +#ifdef CRAY +#define MAXFRACDIGS 9880 +#define MAXINTDIGS 9864 +#else +/* values that suffice for IEEE double */ +#define MAXFRACDIGS 344 +#define MAXINTDIGS 308 +#endif +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c new file mode 100644 index 00000000000..9cc00cba8b9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + longint +#ifdef KR_headers +ftell64_(Unit) integer *Unit; +#else +ftell64_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; + } + + int +#ifdef KR_headers +fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; +#else +fseek64_(integer *Unit, longint *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c new file mode 100644 index 00000000000..be9f2871086 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + integer +#ifdef KR_headers +ftell_(Unit) integer *Unit; +#else +ftell_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; + } + + int +#ifdef KR_headers +fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; +#else +fseek_(integer *Unit, integer *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || fseek(f, *offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c new file mode 100644 index 00000000000..9006ad20169 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c @@ -0,0 +1,34 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* + * subroutine getarg(k, c) + * returns the kth unix command argument in fortran character + * variable argument c +*/ + +#ifdef KR_headers +VOID getarg_(n, s, ls) ftnint *n; register char *s; ftnlen ls; +#else +void getarg_(ftnint *n, register char *s, ftnlen ls) +#endif +{ +extern int xargc; +extern char **xargv; +register char *t; +register int i; + +if(*n>=0 && *n +#include +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, char*); +#endif + +/* + * getenv - f77 subroutine to return environment variables + * + * called by: + * call getenv (ENV_NAME, char_var) + * where: + * ENV_NAME is the name of an environment variable + * char_var is a character variable which will receive + * the current value of ENV_NAME, or all blanks + * if ENV_NAME is not defined + */ + +#ifdef KR_headers + VOID +getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +#else + void +getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) +#endif +{ + char buf[256], *ep, *fp; + integer i; + + if (flen <= 0) + goto add_blanks; + for(i = 0; i < sizeof(buf); i++) { + if (i == flen || (buf[i] = fname[i]) == ' ') { + buf[i] = 0; + ep = getenv(buf); + goto have_ep; + } + } + while(i < flen && fname[i] != ' ') + i++; + strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); + fp[i] = 0; + ep = getenv(fp); + free(fp); + have_ep: + if (ep) + while(*ep && vlen-- > 0) + *value++ = *ep++; + add_blanks: + while(vlen-- > 0) + *value++ = ' '; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c new file mode 100644 index 00000000000..db6906869cf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_abs(x) shortint *x; +#else +shortint h_abs(shortint *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c new file mode 100644 index 00000000000..443427a9b99 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_dim(a,b) shortint *a, *b; +#else +shortint h_dim(shortint *a, shortint *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c new file mode 100644 index 00000000000..1ec641c5aa4 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_dnnt(doublereal *x) +#endif +{ +return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c new file mode 100644 index 00000000000..018f2f43861 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return((shortint)i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c new file mode 100644 index 00000000000..8b0aea99d26 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_len(s, n) char *s; ftnlen n; +#else +shortint h_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c new file mode 100644 index 00000000000..611ef0aa8bf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_mod(a,b) short *a, *b; +#else +shortint h_mod(short *a, short *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c new file mode 100644 index 00000000000..9e2282f2a74 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_nint(real *x) +#endif +{ +return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c new file mode 100644 index 00000000000..4e214380cf9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_sign(a,b) shortint *a, *b; +#else +shortint h_sign(shortint *a, shortint *b) +#endif +{ +shortint x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c new file mode 100644 index 00000000000..8c72f03d489 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c new file mode 100644 index 00000000000..a448522db4b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c new file mode 100644 index 00000000000..31cbc431a3f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c new file mode 100644 index 00000000000..7ad3c714b1d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c new file mode 100644 index 00000000000..60cc24eec19 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c @@ -0,0 +1,343 @@ + char +_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; + +/* +2.01 $ format added +2.02 Coding bug in open.c repaired +2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c + and lio.h (e-format conforming to spec) +2.04 changed open.c and err.c (fopen and freopen respectively) to + update to new c-library (append mode) +2.05 added namelist capability +2.06 allow internal list and namelist I/O +*/ + +/* +close.c: + allow upper-case STATUS= values +endfile.c + create fort.nnn if unit nnn not open; + else if (file length == 0) use creat() rather than copy; + use local copy() rather than forking /bin/cp; + rewind, fseek to clear buffer (for no reading past EOF) +err.c + use neither setbuf nor setvbuf; make stderr buffered +fio.h + #define _bufend +inquire.c + upper case responses; + omit byfile test from SEQUENTIAL= + answer "YES" to DIRECT= for unopened file (open to debate) +lio.c + flush stderr, stdout at end of each stmt + space before character strings in list output only at line start +lio.h + adjust LEW, LED consistent with old libI77 +lread.c + use atof() + allow "nnn*," when reading complex constants +open.c + try opening for writing when open for read fails, with + special uwrt value (2) delaying creat() to first write; + set curunit so error messages don't drop core; + no file name ==> fort.nnn except for STATUS='SCRATCH' +rdfmt.c + use atof(); trust EOF == end-of-file (so don't read past + end-of-file after endfile stmt) +sfe.c + flush stderr, stdout at end of each stmt +wrtfmt.c: + use upper case + put wrt_E and wrt_F into wref.c, use sprintf() + rather than ecvt() and fcvt() [more accurate on VAX] +*/ + +/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ + +/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ + +/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +/* 29 Nov. 1989: change various int return types to long for f2c */ +/* 30 Nov. 1989: various types from f2c.h */ +/* 6 Dec. 1989: types corrected various places */ +/* 19 Dec. 1989: make iostat= work right for internal I/O */ +/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white + space as blank */ +/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads + of logical values reject letters other than fFtT; + have nowwriting reset cf */ +/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as + blank='z...' when reopening an open file */ +/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; + omit exponent field in list output of values of + magnitude between 10 and 1e8; prevent writing stdin + and reading stdout or stderr; don't close stdin, stdout, + or stderr when reopening units 5, 6, 0. */ +/* 18 Sep. 1990: add component udev to unit and consider old == new file + iff uinode and udev values agree; use stat rather than + access to check existence of file (when STATUS='OLD')*/ +/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write + don't clobber the file. */ +/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; + adjust g_char in util.c for segmented memories. */ +/* 17 Oct. 1990: replace abort() and _cleanup() with calls on + sig_die(...,1) (defined in main.c). */ +/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the + file already exists; allow file= to be omitted in open stmts + and allow status='replace' (Fortran 90 extensions). */ +/* 11 Dec. 1990: adjustments for POSIX. */ +/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from + strings in read-only memory. */ +/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +/* 17 Oct. 1991: change type of length field in sequential unformatted + records from int to long (for systems where sizeof(int) + can vary, depending on the compiler or compiler options). */ +/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to + sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); + adjust an error return from EOF to off end of record */ +/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused + the last character of each record to be ignored. + iio.c: adjust error message in internal formatted + input from "end-of-file" to "off end of record" if + the format specifies more characters than the + record contains. */ +/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, + treat "r* ," and "r*," alike (where r is a + positive integer constant), and fix a bug in + handling null values following items with repeat + counts (e.g., 2*1,,3); for namelist reading + of a numeric array, allow a new name-value subsequence + to terminate the current one (as though the current + one ended with the right number of null values). + lio.h, lwrite.c: omit insignificant zeros in + list and namelist output. To get the old + behavior, compile with -DOld_list_output . */ +/* 18 Jan. 1992: make list output consistent with F format by + printing .1 rather than 0.1 (introduced yesterday). */ +/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the + character following a comma to be ignored. */ +/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= + work with internal list and formatted I/O. */ +/* 18 July 1992: adjust rsne.c to allow namelist input to stop at + an & (e.g. &end). */ +/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; + recognize Z format (assuming 8-bit bytes). */ +/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c + (so end-of-file on other files won't confuse namelist + reads of external files). Prepend f__ to external + names that are only of internal interest to lib[FI]77. */ +/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd + buffer == '\n'. + endfile.c: guard against tiny L_tmpnam; close and reopen + files in t_runc(). + lio.h: lengthen LINTW (buffer size in lwrite.c). + err.c, open.c: more prepending of f__ (to [rw]_mode). */ +/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being + sought; namelists of the wrong name are skipped (after + an error message; xwsne.c: namelist writes have a + newline before each new variable. + open.c: ACCESS='APPEND' positions sequential files + at EOF (nonstandard extension -- that doesn't require + changing data structures). */ +/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. + err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) + when the unit has another file descriptor for name. */ +/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; + open.c: always give f__w_mode[] 4 elements for use + in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential + unformatted reads to respond to err= rather than end=. */ +/* 12 March 1993: various tweaks for C++ */ +/* 6 April 1993: adjust error returns for formatted inputs to flush + the current input line when err=label is specified. + To restore the old behavior (input left mid-line), + either adjust the #definition of errfl in fio.h or + omit the invocation of f__doend in err__fl (in err.c). */ +/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for + logical data (during list or namelist input). + Change struct f__syl to struct syl (for buggy compilers). */ +/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete + logical arrays. */ +/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete + array of numeric data followed by another namelist + item whose name starts with 'd', 'D', 'e', or 'E'. */ +/* 8 Sept. 1993: open.c: protect #include "sys/..." with + #ifndef NON_UNIX_STDIO; Version date not changed. */ +/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat + short records as though padded with blanks + (rather than causing an "off end of record" error). */ +/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct + formatted files (avoiding any confusion regarding \n). */ +/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files + under NON_UNIX_STDIO. */ +/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an + optimization that requires exponents to have 2 digits + when 2 digits suffice. + lwrite.c wsfe.c (list and formatted external output): + omit ' ' carriage-control when compiled with + -DOMIT_BLANK_CC . Off-by-one bug fixed in character + count for list output of character strings. + Omit '.' in list-directed printing of Nan, Infinity. */ +/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather + than " .0000E+00". */ +/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an + oversize item to an empty line. */ +/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept + ERR= (in list- or format-directed input) from working + after a NAMELIST READ. */ +/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, + INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 + in NAMELISTs. */ +/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when + GOOD_SPRINTF_EXPONENT is not #defined. */ +/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow + internal reading of characters with high-bit set + (on machines that sign-extend characters). */ +/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to + check for end-of-file (to prevent infinite loops + with empty read statements). */ +/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items + in internal writes whose last item is written to + an earlier position than some previous item. */ +/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name + whose subscripts do not involve colons similarly + to the name without a subscript: accept several + values, stored in successive elements starting at + the indicated subscript. Adjust namelist output + to quote character strings (avoiding confusion with + arrays of character strings). Adjust f_init calls + for people who don't use libF77's main(); now open and + namelist read statements invoke f_init if needed. */ +/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). + Add -DNo_Namelist_Comments lines to rsne.c. */ +/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not + always zeroed in mv_cur). */ +/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c + to err.c */ +/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ + +/* 13 May 1996: add ftell_.c and fseek_.c */ +/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with + too few items in the input string will honor end= . */ +/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, + make ic signed on ANSI systems. If formatted writes of + integer*1 values trouble you when using a K&R C compiler, + switch to an ANSI compiler or use a compiler flag that + makes characters signed. */ +/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= + in direct read and write statements. + ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use + SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats + (but still treat missing ".nnn" as ".0"). */ +/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather + than fully buffered. (Buffering is needed for format + items T and TR.) */ +/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be + treated as 2 on some systems). */ +/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X + draft (in 1990 or 1991) that rescinded permission to elide + quote marks in namelist input of character data; compile + with -DF8X_NML_ELIDE_QUOTES to get the old behavior. + wrtfmt.o: wrt_G: tweak to print the right number of 0's + for zero under G format. */ +/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character + strings that sometimes caused one more array element than + required by the format to be blank-filled. Example: + format(1x). */ +/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines + with 64-bit pointers and 32-bit ints that did not 64-bit + align struct syl (e.g., Linux on the DEC Alpha). */ +/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to + sizeof(uiolen). On machines where this would make a + difference, it is best for portability to compile libI77 with + -DUIOLEN_int (which will render the change invisible). */ +/* 4 March 1998: open.c: fix glitch in comparing file names under + -DNON_UNIX_STDIO */ +/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), + unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). + New buffering scheme independent of NON_UNIX_STDIO for + handling T format items. Now -DNON_UNIX_STDIO is no + longer be necessary for Linux, and libf2c no longer + causes stderr to be buffered -- the former setbuf or + setvbuf call for stderr was to make T format items work. + open.c: use the Posix access() function to check existence + or nonexistence of files, except under -DNON_POSIX_STDIO, + where trial fopen calls are used. */ +/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the + changes of 17 March 1998. */ +/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: + set f__curunit sooner so various error messages will + correctly identify the I/O unit involved. */ +/* 17 June 1998: lread.c: unless compiled with + ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat + floating-point numbers (containing either a decimal point + or an exponent field) as errors when they appear as list + input for integer data. */ +/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. + Why did it ever move to sfe.c? */ +/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" + right in the error message if we cannot open the file). + err.c: cast a pointer difference to (int) for %d. + rdfmt.c: omit fixed-length buffer that could be overwritten + by formats Inn or Lnn with nn > 83. */ +/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ +/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ +/* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */ +/* could cause wrong array elements to be assigned; e.g., */ +/* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */ +/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ +/* endfile statement requires copying the file. */ +/* (Otherwise an immediately following rewind statement */ +/* could make the file appear empty.) Also, supply a */ +/* missing (long) cast in the sprintf call. */ +/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ +/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ +/* any data in buffers should the program fault. It also */ +/* makes the program run more slowly. */ +/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ +/* ftnlen are of different fundamental types (different numbers */ +/* of bits). Since these files will not compile when this */ +/* change matters, the above VERSION string remains unchanged. */ +/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ +/* VERSION string remains unchanged. */ +/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ +/* treat Tstuff= and Fstuff= as new assignments rather than as */ +/* logical constants. */ +/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ +/* -DNO_TRUNCATE (or with -DMSDOS). */ +/* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */ +/* thus permitting truncation of scratch files on true Unix */ +/* systems, where scratch files have no name. Add an fflush() */ +/* (surprisingly) needed on some Linux systems. */ +/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ +/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ +/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ +/* respectively, in fio.h unless otherwise #defined), and use */ +/* type OFF_T (#defined to be long unless otherwise #defined) */ +/* to permit handling files over 2GB long where possible, */ +/* with suitable -D options, provided for some systems in new */ +/* header file sysdep1.h (copied from sysdep1.h0 by default). */ +/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ +/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ +/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ +/* comments in makefile or (better) libf2c/makefile.* . */ +/* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */ +/* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */ +/* 21 March 2003: err.c: before writing to a file after reading from it, */ +/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c new file mode 100644 index 00000000000..2b92c4aa782 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_abs(x) integer *x; +#else +integer i_abs(integer *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c new file mode 100644 index 00000000000..60ed4d8c5b4 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_dim(a,b) integer *a, *b; +#else +integer i_dim(integer *a, integer *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c new file mode 100644 index 00000000000..3abc2dc4a51 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_dnnt(doublereal *x) +#endif +{ +return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c new file mode 100644 index 00000000000..19256393ecd --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c new file mode 100644 index 00000000000..0f7b188d65a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_len(s, n) char *s; ftnlen n; +#else +integer i_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c new file mode 100644 index 00000000000..4a9b5609ba4 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_mod(a,b) integer *a, *b; +#else +integer i_mod(integer *a, integer *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c new file mode 100644 index 00000000000..fe9fd68a86e --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_nint(real *x) +#endif +{ +return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c new file mode 100644 index 00000000000..4c20e9494e1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_sign(a,b) integer *a, *b; +#else +integer i_sign(integer *a, integer *b) +#endif +{ +integer x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c new file mode 100644 index 00000000000..2f29da0eaa6 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +ftnint iargc_() +#else +ftnint iargc_(void) +#endif +{ +extern int xargc; +return ( xargc - 1 ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c new file mode 100644 index 00000000000..8553efcf97f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c @@ -0,0 +1,159 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +char *f__icend; +extern icilist *f__svic; +int f__icnum; + + int +z_getc(Void) +{ + if(f__recpos++ < f__svic->icirlen) { + if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); + return(*(unsigned char *)f__icptr++); + } + return '\n'; +} + + void +#ifdef KR_headers +z_putc(c) +#else +z_putc(int c) +#endif +{ + if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) + *f__icptr++ = c; +} + + int +z_rnew(Void) +{ + f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + return 1; +} + + static int +z_endp(Void) +{ + (*f__donewrec)(); + return 0; + } + + int +#ifdef KR_headers +c_si(a) icilist *a; +#else +c_si(icilist *a) +#endif +{ + f__elist = (cilist *)a; + f__fmtbuf=a->icifmt; + f__curunit = 0; + f__sequential=f__formatted=1; + f__external=0; + if(pars_f(f__fmtbuf)<0) + err(a->icierr,100,"startint"); + fmt_bg(); + f__cblank=f__cplus=f__scale=0; + f__svic=a; + f__icnum=f__recpos=0; + f__cursor = 0; + f__hiwater = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + return(0); +} + + int +iw_rev(Void) +{ + if(f__workdone) + z_endp(); + f__hiwater = f__recpos = f__cursor = 0; + return(f__workdone=0); + } + +#ifdef KR_headers +integer s_rsfi(a) icilist *a; +#else +integer s_rsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=1; + f__doed=rd_ed; + f__doned=rd_ned; + f__getn=z_getc; + f__dorevert = z_endp; + f__donewrec = z_rnew; + f__doend = z_endp; + return(0); +} + + int +z_wnew(Void) +{ + if (f__recpos < f__hiwater) { + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + } + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + f__icnum++; + return 1; +} +#ifdef KR_headers +integer s_wsfi(a) icilist *a; +#else +integer s_wsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=0; + f__doed=w_ed; + f__doned=w_ned; + f__putn=z_putc; + f__dorevert = iw_rev; + f__donewrec = z_wnew; + f__doend = z_endp; + return(0); +} +integer e_rsfi(Void) +{ int n = en_fio(); + f__fmtbuf = NULL; + return(n); +} +integer e_wsfi(Void) +{ + int n; + n = en_fio(); + f__fmtbuf = NULL; + if(f__svic->icirnum != 1 + && (f__icnum > f__svic->icirnum + || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) + err(f__svic->icierr,110,"inwrite"); + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__recpos >= f__svic->icirlen) + err(f__svic->icierr,110,"recend"); + if (!f__recpos && f__icnum) + return n; + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c new file mode 100644 index 00000000000..e8b3d49cf1f --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c @@ -0,0 +1,83 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum; +#ifdef KR_headers +extern void z_putc(); +#else +extern void z_putc(int); +#endif + + static int +z_wSL(Void) +{ + while(f__recpos < f__svic->icirlen) + z_putc(' '); + return z_rnew(); + } + + static void +#ifdef KR_headers +c_liw(a) icilist *a; +#else +c_liw(icilist *a) +#endif +{ + f__reading = 0; + f__external = 0; + f__formatted = 1; + f__putn = z_putc; + L_len = a->icirlen; + f__donewrec = z_wSL; + f__svic = a; + f__icnum = f__recpos = 0; + f__cursor = 0; + f__cf = 0; + f__curunit = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__elist = (cilist *)a; + } + + integer +#ifdef KR_headers +s_wsni(a) icilist *a; +#else +s_wsni(icilist *a) +#endif +{ + cilist ca; + + c_liw(a); + ca.cifmt = a->icifmt; + x_wsne(&ca); + z_wSL(); + return 0; + } + + integer +#ifdef KR_headers +s_wsli(a) icilist *a; +#else +s_wsli(icilist *a) +#endif +{ + f__lioproc = l_write; + c_liw(a); + return(0); + } + +integer e_wsli(Void) +{ + z_wSL(); + return(0); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c new file mode 100644 index 00000000000..5936a674ccc --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c @@ -0,0 +1,117 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifdef NON_UNIX_STDIO +#ifndef MSDOS +#include "unistd.h" /* for access() */ +#endif +#endif +#ifdef KR_headers +integer f_inqu(a) inlist *a; +#else +#ifdef __cplusplus +extern "C" integer f_inqu(inlist*); +#endif +#ifdef MSDOS +#undef abs +#undef min +#undef max +#include "io.h" +#endif +integer f_inqu(inlist *a) +#endif +{ flag byfile; + int i; +#ifndef NON_UNIX_STDIO + int n; +#endif + unit *p; + char buf[256]; + long x; + if(a->infile!=NULL) + { byfile=1; + g_char(a->infile,a->infilen,buf); +#ifdef NON_UNIX_STDIO + x = access(buf,0) ? -1 : 0; + for(i=0,p=NULL;iinunitinunit>=0) + { + p= &f__units[a->inunit]; + } + else + { + p=NULL; + } + } + if(a->inex!=NULL) + if(byfile && x != -1 || !byfile && p!=NULL) + *a->inex=1; + else *a->inex=0; + if(a->inopen!=NULL) + if(byfile) *a->inopen=(p!=NULL); + else *a->inopen=(p!=NULL && p->ufd!=NULL); + if(a->innum!=NULL) *a->innum= p-f__units; + if(a->innamed!=NULL) + if(byfile || p!=NULL && p->ufnm!=NULL) + *a->innamed=1; + else *a->innamed=0; + if(a->inname!=NULL) + if(byfile) + b_char(buf,a->inname,a->innamlen); + else if(p!=NULL && p->ufnm!=NULL) + b_char(p->ufnm,a->inname,a->innamlen); + if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) + if(p->url) + b_char("DIRECT",a->inacc,a->inacclen); + else b_char("SEQUENTIAL",a->inacc,a->inacclen); + if(a->inseq!=NULL) + if(p!=NULL && p->url) + b_char("NO",a->inseq,a->inseqlen); + else b_char("YES",a->inseq,a->inseqlen); + if(a->indir!=NULL) + if(p==NULL || p->url) + b_char("YES",a->indir,a->indirlen); + else b_char("NO",a->indir,a->indirlen); + if(a->infmt!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("UNFORMATTED",a->infmt,a->infmtlen); + else b_char("FORMATTED",a->infmt,a->infmtlen); + if(a->inform!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("NO",a->inform,a->informlen); + else b_char("YES",a->inform,a->informlen); + if(a->inunf) + if(p!=NULL && p->ufmt==0) + b_char("YES",a->inunf,a->inunflen); + else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); + else b_char("UNKNOWN",a->inunf,a->inunflen); + if(a->inrecl!=NULL && p!=NULL) + *a->inrecl=p->url; + if(a->innrec!=NULL && p!=NULL && p->url>0) + *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); + if(a->inblank && p!=NULL && p->ufmt) + if(p->ublnk) + b_char("ZERO",a->inblank,a->inblanklen); + else b_char("NULL",a->inblank,a->inblanklen); + return(0); +} diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c new file mode 100644 index 00000000000..a84f0ee4abc --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c new file mode 100644 index 00000000000..ae6950d1391 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c new file mode 100644 index 00000000000..625b49a9ea9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c new file mode 100644 index 00000000000..ab21b362de9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c new file mode 100644 index 00000000000..5b6ccf72d0a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c @@ -0,0 +1,68 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + + integer +#ifdef KR_headers +lbit_bits(a, b, len) integer a, b, len; +#else +lbit_bits(integer a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + unsigned long x, y; + + x = (unsigned long) a; + y = (unsigned long)-1L; + x >>= b; + y <<= len; + return (integer)(x & ~y); + } + + integer +#ifdef KR_headers +lbit_cshift(a, b, len) integer a, b, len; +#else +lbit_cshift(integer a, integer b, integer len) +#endif +{ + unsigned long x, y, z; + + x = (unsigned long)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONGBITS) { + full_len: + if (b >= 0) { + b %= LONGBITS; + return (integer)(x << b | x >> LONGBITS -b ); + } + b = -b; + b %= LONGBITS; + return (integer)(x << LONGBITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (integer)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (integer)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c new file mode 100644 index 00000000000..fbee94f1403 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +lbit_shift(a, b) integer a; integer b; +#else +lbit_shift(integer a, integer b) +#endif +{ + return b >= 0 ? a << b : (integer)((uinteger)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h new file mode 100644 index 00000000000..012317206aa --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h @@ -0,0 +1,74 @@ +/* copy of ftypes from the compiler */ +/* variable types + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +/* values to allow mixing old and new objects. */ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYLOGICAL 8 +#define TYCHAR 9 +#define TYSUBR 10 +#define TYINT1 11 +#define TYLOGICAL1 12 +#define TYLOGICAL2 13 +#ifdef Allow_TYQUAD +#undef TYQUAD +#define TYQUAD 14 +#endif + +#define LINTW 24 +#define LINE 80 +#define LLOGW 2 +#ifdef Old_list_output +#define LLOW 1.0 +#define LHIGH 1.e9 +#define LEFMT " %# .8E" +#define LFFMT " %# .9g" +#else +#define LGFMT "%.9G" +#endif +/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +#define LEFBL 24 + +typedef union +{ + char flchar; + short flshort; + ftnint flint; +#ifdef Allow_TYQUAD + longint fllongint; +#endif + real flreal; + doublereal fldouble; +} flex; +extern int f__scale; +#ifdef KR_headers +extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +extern int l_read(), l_write(); +#else +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +extern int l_write(ftnint*, char*, ftnlen, ftnint); +extern void x_wsne(cilist*); +extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +extern int l_read(ftnint*,char*,ftnlen,ftnint); +extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +extern int z_rnew(void); +#ifdef __cplusplus + } +#endif +#endif +extern ftnint L_len; diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c new file mode 100644 index 00000000000..55e068bf9fe --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c @@ -0,0 +1,805 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +/* marks in namelist input a la the Fortran 8X Draft published in */ +/* the May 1989 issue of Fortran Forum. */ + + +extern char *f__fmtbuf; + +#ifdef Allow_TYQUAD +static longint f__llx; +#endif + +#ifdef KR_headers +extern double atof(); +extern char *malloc(), *realloc(); +int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "lio.h" +#include "ctype.h" +#include "fp.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef KR_headers +int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), + (*l_ungetc)(int,FILE*); +#endif + +int l_eof; + +#define isblnk(x) (f__ltab[x+1]&B) +#define issep(x) (f__ltab[x+1]&SX) +#define isapos(x) (f__ltab[x+1]&AX) +#define isexp(x) (f__ltab[x+1]&EX) +#define issign(x) (f__ltab[x+1]&SG) +#define iswhit(x) (f__ltab[x+1]&WH) +#define SX 1 +#define B 2 +#define AX 4 +#define EX 8 +#define SG 16 +#define WH 32 +char f__ltab[128+1] = { /* offset one for EOF */ + 0, + 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +}; + +#ifdef ungetc + static int +#ifdef KR_headers +un_getc(x,f__cf) int x; FILE *f__cf; +#else +un_getc(int x, FILE *f__cf) +#endif +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +#ifdef KR_headers + extern int ungetc(); +#else +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + int +t_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + if((ch=getc(f__cf))!=EOF) return(ch); + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return(EOF); +} +integer e_rsle(Void) +{ + int ch; + if(f__curunit->uend) return(0); + while((ch=t_getc())!='\n') + if (ch == EOF) { + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return EOF; + } + return(0); +} + +flag f__lquit; +int f__lcount,f__ltype,nml_read; +char *f__lchar; +double f__lx,f__ly; +#define ERR(x) if(n=(x)) return(n) +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +l_R(poststar, reqint) int poststar, reqint; +#else +l_R(int poststar, int reqint) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + long e, exp; + int havenum, havestar, se; + + if (!poststar) { + if (f__lcount > 0) + return(0); + f__lcount = 1; + } +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + f__ltype = 0; + exp = 0; + havestar = 0; +retry: + sp1 = sp = s; + spe = sp + FMAX; + havenum = 0; + + switch(GETC(ch)) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + GETC(ch); + } + while(ch == '0') { + ++havenum; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) *sp++ = ch; + else ++exp; + GETC(ch); + } + if (ch == '*' && !poststar) { + if (sp == sp1 || exp || *s == '-') { + errfl(f__elist->cierr,112,"bad repetition count"); + } + poststar = havestar = 1; + *sp = 0; + f__lcount = atoi(s); + goto retry; + } + if (ch == '.') { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (sp == sp1) + while(ch == '0') { + ++havenum; + --exp; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) + { *sp++ = ch; --exp; } + GETC(ch); + } + } + havenum += sp - sp1; + se = 0; + if (issign(ch)) + goto signonly; + if (havenum && isexp(ch)) { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (issign(ch)) { +signonly: + if (ch == '-') se = 1; + GETC(ch); + } + if (!isdigit(ch)) { +bad: + errfl(f__elist->cierr,112,"exponent field"); + } + + e = ch - '0'; + while(isdigit(GETC(ch))) { + e = 10*e + ch - '0'; + if (e > EXPMAX) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + } + (void) Ungetc(ch, f__cf); + if (sp > sp1) { + ++havenum; + while(*--sp == '0') + ++exp; + if (exp) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + f__lx = atof(s); +#ifdef Allow_TYQUAD + if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { + /* Assuming 64-bit longint and 32-bit long. */ + if (exp < 0) + sp += exp; + if (sp1 <= sp) { + f__llx = *sp1 - '0'; + while(++sp1 <= sp) + f__llx = 10*f__llx + (*sp1 - '0'); + } + while(--exp >= 0) + f__llx *= 10; + if (*s == '-') + f__llx = -f__llx; + } +#endif + } + else + f__lx = 0.; + if (havenum) + f__ltype = TYLONG; + else + switch(ch) { + case ',': + case '/': + break; + default: + if (havestar && ( ch == ' ' + ||ch == '\t' + ||ch == '\n')) + break; + if (nml_read > 1) { + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"invalid number"); + } + return 0; + } + + static int +#ifdef KR_headers +rd_count(ch) register int ch; +#else +rd_count(register int ch) +#endif +{ + if (ch < '0' || ch > '9') + return 1; + f__lcount = ch - '0'; + while(GETC(ch) >= '0' && ch <= '9') + f__lcount = 10*f__lcount + ch - '0'; + Ungetc(ch,f__cf); + return f__lcount <= 0; + } + + static int +l_C(Void) +{ int ch, nml_save; + double lz; + if(f__lcount>0) return(0); + f__ltype=0; + GETC(ch); + if(ch!='(') + { + if (nml_read > 1 && (ch < '0' || ch > '9')) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + if (rd_count(ch)) + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"complex format"); + else + err(f__elist->cierr,(EOF),"lread"); + if(GETC(ch)!='*') + { + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + } + if(GETC(ch)!='(') + { Ungetc(ch,f__cf); + return(0); + } + } + else + f__lcount = 1; + while(iswhit(GETC(ch))); + Ungetc(ch,f__cf); + nml_save = nml_read; + nml_read = 0; + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no real part"); + lz = f__lx; + while(iswhit(GETC(ch))); + if(ch!=',') + { (void) Ungetc(ch,f__cf); + errfl(f__elist->cierr,112,"no comma"); + } + while(iswhit(GETC(ch))); + (void) Ungetc(ch,f__cf); + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no imaginary part"); + while(iswhit(GETC(ch))); + if(ch!=')') errfl(f__elist->cierr,112,"no )"); + f__ly = f__lx; + f__lx = lz; +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + nml_read = nml_save; + return(0); +} + + static char nmLbuf[256], *nmL_next; + static int (*nmL_getc_save)(Void); +#ifdef KR_headers + static int (*nmL_ungetc_save)(/* int, FILE* */); +#else + static int (*nmL_ungetc_save)(int, FILE*); +#endif + + static int +nmL_getc(Void) +{ + int rv; + if (rv = *nmL_next++) + return rv; + l_getc = nmL_getc_save; + l_ungetc = nmL_ungetc_save; + return (*l_getc)(); + } + + static int +#ifdef KR_headers +nmL_ungetc(x, f) int x; FILE *f; +#else +nmL_ungetc(int x, FILE *f) +#endif +{ + f = f; /* banish non-use warning */ + return *--nmL_next = x; + } + + static int +#ifdef KR_headers +Lfinish(ch, dot, rvp) int ch, dot, *rvp; +#else +Lfinish(int ch, int dot, int *rvp) +#endif +{ + char *s, *se; + static char what[] = "namelist input"; + + s = nmLbuf + 2; + se = nmLbuf + sizeof(nmLbuf) - 1; + *s++ = ch; + while(!issep(GETC(ch)) && ch!=EOF) { + if (s >= se) { + nmLbuf_ovfl: + return *rvp = err__fl(f__elist->cierr,131,what); + } + *s++ = ch; + if (ch != '=') + continue; + if (dot) + return *rvp = err__fl(f__elist->cierr,112,what); + got_eq: + *s = 0; + nmL_getc_save = l_getc; + l_getc = nmL_getc; + nmL_ungetc_save = l_ungetc; + l_ungetc = nmL_ungetc; + nmLbuf[1] = *(nmL_next = nmLbuf) = ','; + *rvp = f__lcount = 0; + return 1; + } + if (dot) + goto done; + for(;;) { + if (s >= se) + goto nmLbuf_ovfl; + *s++ = ch; + if (!isblnk(ch)) + break; + if (GETC(ch) == EOF) + goto done; + } + if (ch == '=') + goto got_eq; + done: + Ungetc(ch, f__cf); + return 0; + } + + static int +l_L(Void) +{ + int ch, rv, sawdot; + + if(f__lcount>0) + return(0); + f__lcount = 1; + f__ltype=0; + GETC(ch); + if(isdigit(ch)) + { + rd_count(ch); + if(GETC(ch)!='*') + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + GETC(ch); + } + sawdot = 0; + if(ch == '.') { + sawdot = 1; + GETC(ch); + } + switch(ch) + { + case 't': + case 'T': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=1; + break; + case 'f': + case 'F': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=0; + break; + default: + if(isblnk(ch) || issep(ch) || ch==EOF) + { (void) Ungetc(ch,f__cf); + return(0); + } + if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"logical"); + } + f__ltype=TYLONG; + while(!issep(GETC(ch)) && ch!=EOF); + Ungetc(ch, f__cf); + return(0); +} + +#define BUFSIZE 128 + + static int +l_CHAR(Void) +{ int ch,size,i; + static char rafail[] = "realloc failure"; + char quote,*p; + if(f__lcount>0) return(0); + f__ltype=0; + if(f__lchar!=NULL) free(f__lchar); + size=BUFSIZE; + p=f__lchar = (char *)malloc((unsigned int)size); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,"no space"); + + GETC(ch); + if(isdigit(ch)) { + /* allow Fortran 8x-style unquoted string... */ + /* either find a repetition count or the string */ + f__lcount = ch - '0'; + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case '*': + if (f__lcount == 0) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) + goto no_quote; +#endif + goto noquote; + } + p = f__lchar; + goto have_lcount; + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__lcount = 1; + f__ltype = TYCHAR; + return *p = 0; + } + if (!isdigit(ch)) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) { + no_quote: + errfl(f__elist->cierr,112, + "undelimited character string"); + } +#endif + goto noquote; + } + *p++ = ch; + f__lcount = 10*f__lcount + ch - '0'; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + else (void) Ungetc(ch,f__cf); + have_lcount: + if(GETC(ch)=='\'' || ch=='"') quote=ch; + else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { + Ungetc(ch,f__cf); + return 0; + } +#ifndef F8X_NML_ELIDE_QUOTES + else if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } +#endif + else { + /* Fortran 8x-style unquoted string */ + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__ltype = TYCHAR; + return *p = 0; + } + noquote: + *p++ = ch; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + f__ltype=TYCHAR; + for(i=0;;) + { while(GETC(ch)!=quote && ch!='\n' + && ch!=EOF && ++icierr,113,rafail); + p=f__lchar+i-1; + *p++ = ch; + } + else if(ch==EOF) return(EOF); + else if(ch=='\n') + { if(*(p-1) != '\\') continue; + i--; + p--; + if(++iciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"stler"); + f__scale=f__recpos=0; + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) + err(a->cierr,102,"lio"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,103,"lio") + return(0); +} + + int +#ifdef KR_headers +l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i,n,ch; + doublereal *yy; + real *xx; + for(i=0;i<*number;i++) + { + if(f__lquit) return(0); + if(l_eof) + err(f__elist->ciend, EOF, "list in") + if(f__lcount == 0) { + f__ltype = 0; + for(;;) { + GETC(ch); + switch(ch) { + case EOF: + err(f__elist->ciend,(EOF),"list in") + case ' ': + case '\t': + case '\n': + continue; + case '/': + f__lquit = 1; + goto loopend; + case ',': + f__lcount = 1; + goto loopend; + default: + (void) Ungetc(ch, f__cf); + goto rddata; + } + } + } + rddata: + switch((int)type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + ERR(l_R(0,1)); + break; +#endif + case TYREAL: + case TYDREAL: + ERR(l_R(0,0)); + break; +#ifdef TYQUAD + case TYQUAD: + n = l_R(0,2); + if (n) + return n; + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + ERR(l_C()); + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + ERR(l_L()); + break; + case TYCHAR: + ERR(l_CHAR()); + break; + } + while (GETC(ch) == ' ' || ch == '\t'); + if (ch != ',' || f__lcount > 1) + Ungetc(ch,f__cf); + loopend: + if(f__lquit) return(0); + if(f__cf && ferror(f__cf)) { + clearerr(f__cf); + errfl(f__elist->cierr,errno,"list in"); + } + if(f__ltype==0) goto bump; + switch((int)type) + { + case TYINT1: + case TYLOGICAL1: + Ptr->flchar = (char)f__lx; + break; + case TYLOGICAL2: + case TYSHORT: + Ptr->flshort = (short)f__lx; + break; + case TYLOGICAL: + case TYLONG: + Ptr->flint = (ftnint)f__lx; + break; +#ifdef Allow_TYQUAD + case TYQUAD: + if (!(Ptr->fllongint = f__llx)) + Ptr->fllongint = f__lx; + break; +#endif + case TYREAL: + Ptr->flreal=f__lx; + break; + case TYDREAL: + Ptr->fldouble=f__lx; + break; + case TYCOMPLEX: + xx=(real *)ptr; + *xx++ = f__lx; + *xx = f__ly; + break; + case TYDCOMPLEX: + yy=(doublereal *)ptr; + *yy++ = f__lx; + *yy = f__ly; + break; + case TYCHAR: + b_char(f__lchar,ptr,len); + break; + } + bump: + if(f__lcount>0) f__lcount--; + ptr += len; + if (nml_read) + nml_read++; + } + return(0); +#undef Ptr +} +#ifdef KR_headers +integer s_rsle(a) cilist *a; +#else +integer s_rsle(cilist *a) +#endif +{ + int n; + + f__reading=1; + f__external=1; + f__formatted=1; + if(n=c_le(a)) return(n); + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + l_eof = 0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c new file mode 100644 index 00000000000..9e0d93deb50 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c @@ -0,0 +1,314 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnint L_len; +int f__Aquote; + + static VOID +donewrec(Void) +{ + if (f__recpos) + (*f__donewrec)(); + } + + static VOID +#ifdef KR_headers +lwrt_I(n) longint n; +#else +lwrt_I(longint n) +#endif +{ + char *p; + int ndigit, sign; + + p = f__icvt(n, &ndigit, &sign, 10); + if(f__recpos + ndigit >= L_len) + donewrec(); + PUT(' '); + if (sign) + PUT('-'); + while(*p) + PUT(*p++); +} + static VOID +#ifdef KR_headers +lwrt_L(n, len) ftnint n; ftnlen len; +#else +lwrt_L(ftnint n, ftnlen len) +#endif +{ + if(f__recpos+LLOGW>=L_len) + donewrec(); + wrt_L((Uint *)&n,LLOGW, len); +} + static VOID +#ifdef KR_headers +lwrt_A(p,len) char *p; ftnlen len; +#else +lwrt_A(char *p, ftnlen len) +#endif +{ + int a; + char *p1, *pe; + + a = 0; + pe = p + len; + if (f__Aquote) { + a = 3; + if (len > 1 && p[len-1] == ' ') { + while(--len > 1 && p[len-1] == ' '); + pe = p + len; + } + p1 = p; + while(p1 < pe) + if (*p1++ == '\'') + a++; + } + if(f__recpos+len+a >= L_len) + donewrec(); + if (a +#ifndef OMIT_BLANK_CC + || !f__recpos +#endif + ) + PUT(' '); + if (a) { + PUT('\''); + while(p < pe) { + if (*p == '\'') + PUT('\''); + PUT(*p++); + } + PUT('\''); + } + else + while(p < pe) + PUT(*p++); +} + + static int +#ifdef KR_headers +l_g(buf, n) char *buf; double n; +#else +l_g(char *buf, double n) +#endif +{ +#ifdef Old_list_output + doublereal absn; + char *fmt; + + absn = n; + if (absn < 0) + absn = -absn; + fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +#ifdef USE_STRLEN + sprintf(buf, fmt, n); + return strlen(buf); +#else + return sprintf(buf, fmt, n); +#endif + +#else + register char *b, c, c1; + + b = buf; + *b++ = ' '; + if (n < 0) { + *b++ = '-'; + n = -n; + } + else + *b++ = ' '; + if (n == 0) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&n)) + *b++ = '-'; +#endif + *b++ = '0'; + *b++ = '.'; + *b = 0; + goto f__ret; + } + sprintf(b, LGFMT, n); + switch(*b) { +#ifndef WANT_LEAD_0 + case '0': + while(b[0] = b[1]) + b++; + break; +#endif + case 'i': + case 'I': + /* Infinity */ + case 'n': + case 'N': + /* NaN */ + while(*++b); + break; + + default: + /* Fortran 77 insists on having a decimal point... */ + for(;; b++) + switch(*b) { + case 0: + *b++ = '.'; + *b = 0; + goto f__ret; + case '.': + while(*++b); + goto f__ret; + case 'E': + for(c1 = '.', c = 'E'; *b = c1; + c1 = c, c = *++b); + goto f__ret; + } + } + f__ret: + return b - buf; +#endif + } + + static VOID +#ifdef KR_headers +l_put(s) register char *s; +#else +l_put(register char *s) +#endif +{ +#ifdef KR_headers + register void (*pn)() = f__putn; +#else + register void (*pn)(int) = f__putn; +#endif + register int c; + + while(c = *s++) + (*pn)(c); + } + + static VOID +#ifdef KR_headers +lwrt_F(n) double n; +#else +lwrt_F(double n) +#endif +{ + char buf[LEFBL]; + + if(f__recpos + l_g(buf,n) >= L_len) + donewrec(); + l_put(buf); +} + static VOID +#ifdef KR_headers +lwrt_C(a,b) double a,b; +#else +lwrt_C(double a, double b) +#endif +{ + char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; + int al, bl; + + al = l_g(bufa, a); + for(ba = bufa; *ba == ' '; ba++) + --al; + bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ + for(bb = bufb; *bb == ' '; bb++) + --bl; + if(f__recpos + al + bl + 3 >= L_len) + donewrec(); +#ifdef OMIT_BLANK_CC + else +#endif + PUT(' '); + PUT('('); + l_put(ba); + PUT(','); + if (f__recpos + bl >= L_len) { + (*f__donewrec)(); +#ifndef OMIT_BLANK_CC + PUT(' '); +#endif + } + l_put(bb); + PUT(')'); +} + + int +#ifdef KR_headers +l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i; + longint x; + double y,z; + real *xx; + doublereal *yy; + for(i=0;i< *number; i++) + { + switch((int)type) + { + default: f__fatal(117,"unknown type in lio"); + case TYINT1: + x = Ptr->flchar; + goto xint; + case TYSHORT: + x=Ptr->flshort; + goto xint; +#ifdef Allow_TYQUAD + case TYQUAD: + x = Ptr->fllongint; + goto xint; +#endif + case TYLONG: + x=Ptr->flint; + xint: lwrt_I(x); + break; + case TYREAL: + y=Ptr->flreal; + goto xfloat; + case TYDREAL: + y=Ptr->fldouble; + xfloat: lwrt_F(y); + break; + case TYCOMPLEX: + xx= &Ptr->flreal; + y = *xx++; + z = *xx; + goto xcomplex; + case TYDCOMPLEX: + yy = &Ptr->fldouble; + y= *yy++; + z = *yy; + xcomplex: + lwrt_C(y,z); + break; + case TYLOGICAL1: + x = Ptr->flchar; + goto xlog; + case TYLOGICAL2: + x = Ptr->flshort; + goto xlog; + case TYLOGICAL: + x = Ptr->flint; + xlog: lwrt_L(Ptr->flint, len); + break; + case TYCHAR: + lwrt_A(ptr,len); + break; + } + ptr += len; + } + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c new file mode 100644 index 00000000000..45397490471 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c @@ -0,0 +1,147 @@ +/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ + +#include "stdio.h" +#include "signal1.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifndef KR_headers +#undef VOID +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#ifndef VOID +#define VOID void +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef NO__STDC +#define ONEXIT onexit +extern VOID f_exit(); +#else +#ifndef KR_headers +extern void f_exit(void); +#ifndef NO_ONEXIT +#define ONEXIT atexit +extern int atexit(void (*)(void)); +#endif +#else +#ifndef NO_ONEXIT +#define ONEXIT onexit +extern VOID f_exit(); +#endif +#endif +#endif + +#ifdef KR_headers +extern VOID f_init(), sig_die(); +extern int MAIN__(); +#define Int /* int */ +#else +extern void f_init(void), sig_die(char*, int); +extern int MAIN__(void); +#define Int int +#endif + +static VOID sigfdie(Sigarg) +{ +Use_Sigarg; +sig_die("Floating Exception", 1); +} + + +static VOID sigidie(Sigarg) +{ +Use_Sigarg; +sig_die("IOT Trap", 1); +} + +#ifdef SIGQUIT +static VOID sigqdie(Sigarg) +{ +Use_Sigarg; +sig_die("Quit signal", 1); +} +#endif + + +static VOID sigindie(Sigarg) +{ +Use_Sigarg; +sig_die("Interrupt", 0); +} + +static VOID sigtdie(Sigarg) +{ +Use_Sigarg; +sig_die("Killed", 0); +} + +#ifdef SIGTRAP +static VOID sigtrdie(Sigarg) +{ +Use_Sigarg; +sig_die("Trace trap", 1); +} +#endif + + +int xargc; +char **xargv; + +#ifdef __cplusplus + } +#endif + +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ +xargc = argc; +xargv = argv; +signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +#ifdef SIGIOT +signal1(SIGIOT, sigidie); +#endif +#ifdef SIGTRAP +signal1(SIGTRAP, sigtrdie); +#endif +#ifdef SIGQUIT +if(signal1(SIGQUIT,sigqdie) == SIG_IGN) + signal1(SIGQUIT, SIG_IGN); +#endif +if(signal1(SIGINT, sigindie) == SIG_IGN) + signal1(SIGINT, SIG_IGN); +signal1(SIGTERM,sigtdie); + +#ifdef pdp11 + ldfps(01200); /* detect overflow as an exception */ +#endif + +f_init(); +#ifndef NO_ONEXIT +ONEXIT(f_exit); +#endif +MAIN__(); +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +return 0; /* For compilers that complain of missing return values; */ + /* others will complain that this is unreachable code. */ +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c new file mode 100644 index 00000000000..6e3def121df --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c @@ -0,0 +1,299 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifndef NON_POSIX_STDIO +#ifdef MSDOS +#include "io.h" +#else +#include "unistd.h" /* for access */ +#endif +#endif + +#ifdef KR_headers +extern char *malloc(); +#ifdef NON_ANSI_STDIO +extern char *mktemp(); +#endif +extern integer f_clos(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern int f__canseek(FILE*); +extern integer f_clos(cllist*); +#endif + +#ifdef NON_ANSI_RW_MODES +char *f__r_mode[2] = {"r", "r"}; +char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +#else +char *f__r_mode[2] = {"rb", "r"}; +char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +#endif + + static char f__buf0[400], *f__buf = f__buf0; + int f__buflen = (int)sizeof(f__buf0); + + static void +#ifdef KR_headers +f__bufadj(n, c) int n, c; +#else +f__bufadj(int n, int c) +#endif +{ + unsigned int len; + char *nbuf, *s, *t, *te; + + if (f__buf == f__buf0) + f__buflen = 1024; + while(f__buflen <= n) + f__buflen <<= 1; + len = (unsigned int)f__buflen; + if (len != f__buflen || !(nbuf = (char*)malloc(len))) + f__fatal(113, "malloc failure"); + s = nbuf; + t = f__buf; + te = t + c; + while(t < te) + *s++ = *t++; + if (f__buf != f__buf0) + free(f__buf); + f__buf = nbuf; + } + + int +#ifdef KR_headers +f__putbuf(c) int c; +#else +f__putbuf(int c) +#endif +{ + char *s, *se; + int n; + + if (f__hiwater > f__recpos) + f__recpos = f__hiwater; + n = f__recpos + 1; + if (n >= f__buflen) + f__bufadj(n, f__recpos); + s = f__buf; + se = s + f__recpos; + if (c) + *se++ = c; + *se = 0; + for(;;) { + fputs(s, f__cf); + s += strlen(s); + if (s >= se) + break; /* normally happens the first time */ + putc(*s++, f__cf); + } + return 0; + } + + void +#ifdef KR_headers +x_putc(c) +#else +x_putc(int c) +#endif +{ + if (f__recpos >= f__buflen) + f__bufadj(f__recpos, f__buflen); + f__buf[f__recpos++] = c; + } + +#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} + + static void +#ifdef KR_headers +opn_err(m, s, a) int m; char *s; olist *a; +#else +opn_err(int m, char *s, olist *a) +#endif +{ + if (a->ofnm) { + /* supply file name to error message */ + if (a->ofnmlen >= f__buflen) + f__bufadj((int)a->ofnmlen, 0); + g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); + } + f__fatal(m, s); + } + +#ifdef KR_headers +integer f_open(a) olist *a; +#else +integer f_open(olist *a) +#endif +{ unit *b; + integer rv; + char buf[256], *s; + cllist x; + int ufmt; + FILE *tf; +#ifndef NON_UNIX_STDIO + int n; +#endif + f__external = 1; + if(a->ounit>=MXUNIT || a->ounit<0) + err(a->oerr,101,"open") + if (!f__init) + f_init(); + f__curunit = b = &f__units[a->ounit]; + if(b->ufd) { + if(a->ofnm==0) + { + same: if (a->oblnk) + b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; + return(0); + } +#ifdef NON_UNIX_STDIO + if (b->ufnm + && strlen(b->ufnm) == a->ofnmlen + && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) + goto same; +#else + g_char(a->ofnm,a->ofnmlen,buf); + if (f__inode(buf,&n) == b->uinode && n == b->udev) + goto same; +#endif + x.cunit=a->ounit; + x.csta=0; + x.cerr=a->oerr; + if ((rv = f_clos(&x)) != 0) + return rv; + } + b->url = (int)a->orl; + b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); + if(a->ofm==0) + { if(b->url>0) b->ufmt=0; + else b->ufmt=1; + } + else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; + else b->ufmt=0; + ufmt = b->ufmt; +#ifdef url_Adjust + if (b->url && !ufmt) + url_Adjust(b->url); +#endif + if (a->ofnm) { + g_char(a->ofnm,a->ofnmlen,buf); + if (!buf[0]) + opnerr(a->oerr,107,"open") + } + else + sprintf(buf, "fort.%ld", (long)a->ounit); + b->uscrtch = 0; + b->uend=0; + b->uwrt = 0; + b->ufd = 0; + b->urw = 3; + switch(a->osta ? *a->osta : 'u') + { + case 'o': + case 'O': +#ifdef NON_POSIX_STDIO + if (!(tf = FOPEN(buf,"r"))) + opnerr(a->oerr,errno,"open") + fclose(tf); +#else + if (access(buf,0)) + opnerr(a->oerr,errno,"open") +#endif + break; + case 's': + case 'S': + b->uscrtch=1; +#ifdef NON_ANSI_STDIO + (void) strcpy(buf,"tmp.FXXXXXX"); + (void) mktemp(buf); + goto replace; +#else + if (!(b->ufd = tmpfile())) + opnerr(a->oerr,errno,"open") + b->ufnm = 0; +#ifndef NON_UNIX_STDIO + b->uinode = b->udev = -1; +#endif + b->useek = 1; + return 0; +#endif + + case 'n': + case 'N': +#ifdef NON_POSIX_STDIO + if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { + fclose(tf); + opnerr(a->oerr,128,"open") + } +#else + if (!access(buf,0)) + opnerr(a->oerr,128,"open") +#endif + /* no break */ + case 'r': /* Fortran 90 replace option */ + case 'R': +#ifdef NON_ANSI_STDIO + replace: +#endif + if (tf = FOPEN(buf,f__w_mode[0])) + fclose(tf); + } + + b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); + if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); + (void) strcpy(b->ufnm,buf); + if ((s = a->oacc) && b->url) + ufmt = 0; + if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { + if (tf = FOPEN(buf, f__r_mode[ufmt])) + b->urw = 1; + else if (tf = FOPEN(buf, f__w_mode[ufmt])) { + b->uwrt = 1; + b->urw = 2; + } + else + err(a->oerr, errno, "open"); + } + b->useek = f__canseek(b->ufd = tf); +#ifndef NON_UNIX_STDIO + if((b->uinode = f__inode(buf,&b->udev)) == -1) + opnerr(a->oerr,108,"open") +#endif + if(b->useek) + if (a->orl) + rewind(b->ufd); + else if ((s = a->oacc) && (*s == 'a' || *s == 'A') + && FSEEK(b->ufd, 0L, SEEK_END)) + opnerr(a->oerr,129,"open"); + return(0); +} + + int +#ifdef KR_headers +fk_open(seq,fmt,n) ftnint n; +#else +fk_open(int seq, int fmt, ftnint n) +#endif +{ char nbuf[10]; + olist a; + (void) sprintf(nbuf,"fort.%ld",(long)n); + a.oerr=1; + a.ounit=n; + a.ofnm=nbuf; + a.ofnmlen=strlen(nbuf); + a.osta=NULL; + a.oacc= (char*)(seq==SEQ?"s":"d"); + a.ofm = (char*)(fmt==FMT?"f":"u"); + a.orl = seq==DIR?1:0; + a.oblnk=NULL; + return(f_open(&a)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c new file mode 100644 index 00000000000..574e0b1ebac --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_ci(p, a, b) /* p = a**b */ + complex *p, *a; integer *b; +#else +extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +#endif +{ +doublecomplex p1, a1; + +a1.r = a->r; +a1.i = a->i; + +pow_zi(&p1, &a1, b); + +p->r = p1.r; +p->i = p1.i; +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c new file mode 100644 index 00000000000..08fc20884ae --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow(); +double pow_dd(ap, bp) doublereal *ap, *bp; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double pow_dd(doublereal *ap, doublereal *bp) +#endif +{ +return(pow(*ap, *bp) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c new file mode 100644 index 00000000000..abf36cb74c0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_di(ap, bp) doublereal *ap; integer *bp; +#else +double pow_di(doublereal *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c new file mode 100644 index 00000000000..882168501aa --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint pow_hh(ap, bp) shortint *ap, *bp; +#else +shortint pow_hh(shortint *ap, shortint *bp) +#endif +{ + shortint pow, x, n; + unsigned u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c new file mode 100644 index 00000000000..748d1217733 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer pow_ii(ap, bp) integer *ap, *bp; +#else +integer pow_ii(integer *ap, integer *bp) +#endif +{ + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c new file mode 100644 index 00000000000..09fe18ec8e7 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +longint pow_qq(ap, bp) longint *ap, *bp; +#else +longint pow_qq(longint *ap, longint *bp) +#endif +{ + longint pow, x, n; + unsigned long long u; /* system-dependent */ + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c new file mode 100644 index 00000000000..e29d416eba2 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_ri(ap, bp) real *ap; integer *bp; +#else +double pow_ri(real *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c new file mode 100644 index 00000000000..1c0a4b07c2d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c @@ -0,0 +1,60 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_zi(p, a, b) /* p = a**b */ + doublecomplex *p, *a; integer *b; +#else +extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ +#endif +{ + integer n; + unsigned long u; + double t; + doublecomplex q, x; + static doublecomplex one = {1.0, 0.0}; + + n = *b; + q.r = 1; + q.i = 0; + + if(n == 0) + goto done; + if(n < 0) + { + n = -n; + z_div(&x, &one, a); + } + else + { + x.r = a->r; + x.i = a->i; + } + + for(u = n; ; ) + { + if(u & 01) + { + t = q.r * x.r - q.i * x.i; + q.i = q.r * x.i + q.i * x.r; + q.r = t; + } + if(u >>= 1) + { + t = x.r * x.r - x.i * x.i; + x.i = 2 * x.r * x.i; + x.r = t; + } + else + break; + } + done: + p->i = q.i; + p->r = q.r; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c new file mode 100644 index 00000000000..b5ffd334835 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c @@ -0,0 +1,29 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), exp(), cos(), sin(), atan2(), f__cabs(); +VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double,double); +void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +#endif +{ +double logr, logi, x, y; + +logr = log( f__cabs(a->r, a->i) ); +logi = atan2(a->i, a->r); + +x = exp( logr * b->r - logi * b->i ); +y = logr * b->i + logi * b->r; + +r->r = x * cos(y); +r->i = x * sin(y); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c new file mode 100644 index 00000000000..ba1b5bd0c97 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c @@ -0,0 +1,72 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + +#ifndef LONG8BITS +#define LONG8BITS (2*LONGBITS) +#endif + + longint +#ifdef KR_headers +qbit_bits(a, b, len) longint a; integer b, len; +#else +qbit_bits(longint a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + ulongint x, y; + + x = (ulongint) a; + y = (ulongint)-1L; + x >>= b; + y <<= len; + return (longint)(x & ~y); + } + + longint +#ifdef KR_headers +qbit_cshift(a, b, len) longint a; integer b, len; +#else +qbit_cshift(longint a, integer b, integer len) +#endif +{ + ulongint x, y, z; + + x = (ulongint)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONG8BITS) { + full_len: + if (b >= 0) { + b %= LONG8BITS; + return (longint)(x << b | x >> LONG8BITS - b ); + } + b = -b; + b %= LONG8BITS; + return (longint)(x << LONG8BITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (longint)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (longint)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c new file mode 100644 index 00000000000..78e7b95100d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + longint +#ifdef KR_headers +qbit_shift(a, b) longint a; integer b; +#else +qbit_shift(longint a, integer b) +#endif +{ + return b >= 0 ? a << b : (longint)((ulongint)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c new file mode 100644 index 00000000000..f3291fb4d14 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_abs(x) real *x; +#else +double r_abs(real *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c new file mode 100644 index 00000000000..103c7ff070b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double r_acos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_acos(real *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c new file mode 100644 index 00000000000..432b9406ac7 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double r_asin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_asin(real *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c new file mode 100644 index 00000000000..7656982db45 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double r_atan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atan(real *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c new file mode 100644 index 00000000000..ab957b89d54 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double r_atn2(x,y) real *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atn2(real *x, real *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c new file mode 100644 index 00000000000..cef0e4b092b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID r_cnjg(r, z) complex *r, *z; +#else +VOID r_cnjg(complex *r, complex *z) +#endif +{ + real zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c new file mode 100644 index 00000000000..4418f0c1bbf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double r_cos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cos(real *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c new file mode 100644 index 00000000000..f5478355809 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double r_cosh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cosh(real *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c new file mode 100644 index 00000000000..d573ca36d8d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_dim(a,b) real *a, *b; +#else +double r_dim(real *a, real *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c new file mode 100644 index 00000000000..4e679794f22 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double r_exp(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_exp(real *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c new file mode 100644 index 00000000000..1b4de14373a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_imag(z) complex *z; +#else +double r_imag(complex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c new file mode 100644 index 00000000000..bff87176ff6 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_int(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_int(real *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c new file mode 100644 index 00000000000..64ffddf48b0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double r_lg10(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_lg10(real *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c new file mode 100644 index 00000000000..94c79b05185 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double r_log(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_log(real *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c new file mode 100644 index 00000000000..63ed1753689 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double r_mod(x,y) real *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double r_mod(real *x, real *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = (double)*x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c new file mode 100644 index 00000000000..7cc3f1b5aea --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c new file mode 100644 index 00000000000..797db1a4cbf --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_sign(a,b) real *a, *b; +#else +double r_sign(real *a, real *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c new file mode 100644 index 00000000000..37e0df25fa5 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double r_sin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sin(real *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c new file mode 100644 index 00000000000..39878f03ae7 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double r_sinh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sinh(real *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c new file mode 100644 index 00000000000..e7b2c1c704a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double r_sqrt(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sqrt(real *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c new file mode 100644 index 00000000000..1774bed73a5 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double r_tan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tan(real *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c new file mode 100644 index 00000000000..7739c6ce846 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double r_tanh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tanh(real *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h new file mode 100644 index 00000000000..fd36a482602 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h @@ -0,0 +1,41 @@ +#ifndef KR_headers +#ifdef MSDOS +#include "io.h" +#ifndef WATCOM +#define close _close +#define creat _creat +#define open _open +#define read _read +#define write _write +#endif /*WATCOM*/ +#endif /*MSDOS*/ +#ifdef __cplusplus +extern "C" { +#endif +#ifndef MSDOS +#ifdef OPEN_DECL +extern int creat(const char*,int), open(const char*,int); +#endif +extern int close(int); +extern int read(int,void*,size_t), write(int,void*,size_t); +extern int unlink(const char*); +#ifndef _POSIX_SOURCE +#ifndef NON_UNIX_STDIO +extern FILE *fdopen(int, const char*); +#endif +#endif +#endif /*KR_HEADERS*/ + +extern char *mktemp(char*); + +#ifdef __cplusplus + } +#endif +#endif + +#include "fcntl.h" + +#ifndef O_WRONLY +#define O_RDONLY 0 +#define O_WRONLY 1 +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c new file mode 100644 index 00000000000..62b28053409 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c @@ -0,0 +1,550 @@ +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +extern double atof(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "fp.h" +#include "ctype.h" +#ifdef __cplusplus +extern "C" { +#endif + + static int +#ifdef KR_headers +rd_Z(n,w,len) Uint *n; ftnlen len; +#else +rd_Z(Uint *n, int w, ftnlen len) +#endif +{ + long x[9]; + char *s, *s0, *s1, *se, *t; + int ch, i, w1, w2; + static char hex[256]; + static int one = 1; + int bad = 0; + + if (!hex['0']) { + s = "0123456789"; + while(ch = *s++) + hex[ch] = ch - '0' + 1; + s = "ABCDEF"; + while(ch = *s++) + hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; + } + s = s0 = (char *)x; + s1 = (char *)&x[4]; + se = (char *)&x[8]; + if (len > 4*sizeof(long)) + return errno = 117; + while (w) { + GET(ch); + if (ch==',' || ch=='\n') + break; + w--; + if (ch > ' ') { + if (!hex[ch & 0xff]) + bad++; + *s++ = ch; + if (s == se) { + /* discard excess characters */ + for(t = s0, s = s1; t < s1;) + *t++ = *s++; + s = s1; + } + } + } + if (bad) + return errno = 115; + w = (int)len; + w1 = s - s0; + w2 = w1+1 >> 1; + t = (char *)n; + if (*(char *)&one) { + /* little endian */ + t += w - 1; + i = -1; + } + else + i = 1; + for(; w > w2; t += i, --w) + *t = 0; + if (!w) + return 0; + if (w < w2) + s0 = s - (w << 1); + else if (w1 & 1) { + *t = hex[*s0++ & 0xff] - 1; + if (!--w) + return 0; + t += i; + } + do { + *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; + t += i; + s0 += 2; + } + while(--w); + return 0; + } + + static int +#ifdef KR_headers +rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +#else +rd_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ + int ch, sign; + longint x = 0; + + if (w <= 0) + goto have_x; + for(;;) { + GET(ch); + if (ch != ' ') + break; + if (!--w) + goto have_x; + } + sign = 0; + switch(ch) { + case ',': + case '\n': + w = 0; + goto have_x; + case '-': + sign = 1; + case '+': + break; + default: + if (ch >= '0' && ch <= '9') { + x = ch - '0'; + break; + } + goto have_x; + } + while(--w) { + GET(ch); + if (ch >= '0' && ch <= '9') { + x = x*base + ch - '0'; + continue; + } + if (ch != ' ') { + if (ch == '\n' || ch == ',') + w = 0; + break; + } + if (f__cblank) + x *= base; + } + if (sign) + x = -x; + have_x: + if(len == sizeof(integer)) + n->il=x; + else if(len == sizeof(char)) + n->ic = (char)x; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) + n->ili = x; +#endif + else + n->is = (short)x; + if (w) { + while(--w) + GET(ch); + return errno = 115; + } + return 0; +} + + static int +#ifdef KR_headers +rd_L(n,w,len) ftnint *n; ftnlen len; +#else +rd_L(ftnint *n, int w, ftnlen len) +#endif +{ int ch, dot, lv; + + if (w <= 0) + goto bad; + for(;;) { + GET(ch); + --w; + if (ch != ' ') + break; + if (!w) + goto bad; + } + dot = 0; + retry: + switch(ch) { + case '.': + if (dot++ || !w) + goto bad; + GET(ch); + --w; + goto retry; + case 't': + case 'T': + lv = 1; + break; + case 'f': + case 'F': + lv = 0; + break; + default: + bad: + for(; w > 0; --w) + GET(ch); + /* no break */ + case ',': + case '\n': + return errno = 116; + } + switch(len) { + case sizeof(char): *(char *)n = (char)lv; break; + case sizeof(short): *(short *)n = (short)lv; break; + default: *n = lv; + } + while(w-- > 0) { + GET(ch); + if (ch == ',' || ch == '\n') + break; + } + return 0; +} + + static int +#ifdef KR_headers +rd_F(p, w, d, len) ufloat *p; ftnlen len; +#else +rd_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + double x; + int scale1, se; + long e, exp; + + sp1 = sp = s; + spe = sp + FMAX; + exp = -d; + x = 0.; + + do { + GET(ch); + w--; + } while (ch == ' ' && w); + switch(ch) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + if (!w) goto zero; + --w; + GET(ch); + } + while(ch == ' ') { +blankdrop: + if (!w--) goto zero; GET(ch); } + while(ch == '0') + { if (!w--) goto zero; GET(ch); } + if (ch == ' ' && f__cblank) + goto blankdrop; + scale1 = f__scale; + while(isdigit(ch)) { +digloop1: + if (sp < spe) *sp++ = ch; + else ++exp; +digloop1e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop1; } + goto digloop1e; + } + if (ch == '.') { + exp += d; + if (!w--) goto done; + GET(ch); + if (sp == sp1) { /* no digits yet */ + while(ch == '0') { +skip01: + --exp; +skip0: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) goto skip01; + goto skip0; + } + } + while(isdigit(ch)) { +digloop2: + if (sp < spe) + { *sp++ = ch; --exp; } +digloop2e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop2; } + goto digloop2e; + } + } + switch(ch) { + default: + break; + case '-': se = 1; goto signonly; + case '+': se = 0; goto signonly; + case 'e': + case 'E': + case 'd': + case 'D': + if (!w--) + goto bad; + GET(ch); + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + se = 0; + switch(ch) { + case '-': se = 1; + case '+': +signonly: + if (!w--) + goto bad; + GET(ch); + } + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + if (!isdigit(ch)) + goto bad; + + e = ch - '0'; + for(;;) { + if (!w--) + { ch = '\n'; break; } + GET(ch); + if (!isdigit(ch)) { + if (ch == ' ') { + if (f__cblank) + ch = '0'; + else continue; + } + else + break; + } + e = 10*e + ch - '0'; + if (e > EXPMAX && sp > sp1) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + scale1 = 0; + } + switch(ch) { + case '\n': + case ',': + break; + default: +bad: + return (errno = 115); + } +done: + if (sp > sp1) { + while(*--sp == '0') + ++exp; + if (exp -= scale1) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + x = atof(s); + } +zero: + if (len == sizeof(real)) + p->pf = x; + else + p->pd = x; + return(0); + } + + + static int +#ifdef KR_headers +rd_A(p,len) char *p; ftnlen len; +#else +rd_A(char *p, ftnlen len) +#endif +{ int i,ch; + for(i=0;i=len) + { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); + if(f__cursor<0) + { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ + f__cursor = -f__recpos; /* is this in the standard? */ + if(f__external == 0) { + extern char *f__icptr; + f__icptr += f__cursor; + } + else if(f__curunit && f__curunit->useek) + (void) FSEEK(f__cf, f__cursor,SEEK_CUR); + else + err(f__elist->cierr,106,"fmt"); + f__recpos += f__cursor; + f__cursor=0; + } + switch(p->op) + { + default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case IM: + case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); + break; + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case OM: + case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); + break; + case L: ch = rd_L((ftnint *)ptr,p->p1,len); + break; + case A: ch = rd_A(ptr,len); + break; + case AW: + ch = rd_AW(ptr,p->p1,len); + break; + case E: case EE: + case D: + case G: + case GE: + case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); + break; + + /* Z and ZM assume 8-bit bytes. */ + + case ZM: + case Z: + ch = rd_Z((Uint *)ptr, p->p1, len); + break; + } + if(ch == 0) return(ch); + else if(ch == EOF) return(EOF); + if (f__cf) + clearerr(f__cf); + return(errno); +} + + int +#ifdef KR_headers +rd_ned(p) struct syl *p; +#else +rd_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case APOS: + return(rd_POS(p->p2.s)); + case H: return(rd_H(p->p1,p->p2.s)); + case SLASH: return((*f__donewrec)()); + case TR: + case X: f__cursor += p->p1; + return(1); + case T: f__cursor=p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + } +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c new file mode 100644 index 00000000000..9a0e07e6cfa --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c @@ -0,0 +1,30 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_rew(a) alist *a; +#else +integer f_rew(alist *a) +#endif +{ + unit *b; + if(a->aunit>=MXUNIT || a->aunit<0) + err(a->aerr,101,"rewind"); + b = &f__units[a->aunit]; + if(b->ufd == NULL || b->uwrt == 3) + return(0); + if(!b->useek) + err(a->aerr,106,"rewind") + if(b->uwrt) { + (void) t_runc(a); + b->uwrt = 3; + } + rewind(b->ufd); + b->uend=0; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c new file mode 100644 index 00000000000..abe9724a7b8 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c @@ -0,0 +1,91 @@ +/* read sequential formatted external */ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +xrd_SL(Void) +{ int ch; + if(!f__curunit->uend) + while((ch=getc(f__cf))!='\n') + if (ch == EOF) { + f__curunit->uend = 1; + break; + } + f__cursor=f__recpos=0; + return(1); +} + + int +x_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + ch = getc(f__cf); + if(ch!=EOF && ch!='\n') + { f__recpos++; + return(ch); + } + if(ch=='\n') + { (void) ungetc(ch,f__cf); + return(ch); + } + if(f__curunit->uend || feof(f__cf)) + { errno=0; + f__curunit->uend=1; + return(-1); + } + return(-1); +} + + int +x_endp(Void) +{ + xrd_SL(); + return f__curunit->uend == 1 ? EOF : 0; +} + + int +x_rev(Void) +{ + (void) xrd_SL(); + return(0); +} +#ifdef KR_headers +integer s_rsfe(a) cilist *a; /* start */ +#else +integer s_rsfe(cilist *a) /* start */ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=1; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__cursor=f__recpos=0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__getn= x_getc; + f__doed= rd_ed; + f__doned= rd_ned; + fmt_bg(); + f__doend=x_endp; + f__donewrec=xrd_SL; + f__dorevert=x_rev; + f__cblank=f__curunit->ublnk; + f__cplus=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c new file mode 100644 index 00000000000..3d4ea428fc9 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c @@ -0,0 +1,109 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" /* for f__doend */ +#ifdef __cplusplus +extern "C" { +#endif + +extern flag f__lquit; +extern int f__lcount; +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum, f__recpos; + +static int i_getc(Void) +{ + if(f__recpos >= f__svic->icirlen) { + if (f__recpos++ == f__svic->icirlen) + return '\n'; + z_rnew(); + } + f__recpos++; + if(f__icptr >= f__icend) + return EOF; + return(*f__icptr++); + } + + static +#ifdef KR_headers +int i_ungetc(ch, f) int ch; FILE *f; +#else +int i_ungetc(int ch, FILE *f) +#endif +{ + if (--f__recpos == f__svic->icirlen) + return '\n'; + if (f__recpos < -1) + err(f__svic->icierr,110,"recend"); + /* *--icptr == ch, and icptr may point to read-only memory */ + return *--f__icptr /* = ch */; + } + + static void +#ifdef KR_headers +c_lir(a) icilist *a; +#else +c_lir(icilist *a) +#endif +{ + extern int l_eof; + f__reading = 1; + f__external = 0; + f__formatted = 1; + f__svic = a; + L_len = a->icirlen; + f__recpos = -1; + f__icnum = f__recpos = 0; + f__cursor = 0; + l_getc = i_getc; + l_ungetc = i_ungetc; + l_eof = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + f__curunit = 0; + f__elist = (cilist *)a; + } + + +#ifdef KR_headers +integer s_rsli(a) icilist *a; +#else +integer s_rsli(icilist *a) +#endif +{ + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + c_lir(a); + f__doend = 0; + return(0); + } + +integer e_rsli(Void) +{ return 0; } + +#ifdef KR_headers +integer s_rsni(a) icilist *a; +#else +extern int x_rsne(cilist*); + +integer s_rsni(icilist *a) +#endif +{ + extern int nml_read; + integer rv; + cilist ca; + ca.ciend = a->iciend; + ca.cierr = a->icierr; + ca.cifmt = a->icifmt; + c_lir(a); + rv = x_rsne(&ca); + nml_read = 0; + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c new file mode 100644 index 00000000000..f3fcfac13b1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c @@ -0,0 +1,616 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +#define MAXDIM 20 /* maximum number of subscripts */ + + struct dimen { + ftnlen extent; + ftnlen curval; + ftnlen delta; + ftnlen stride; + }; + typedef struct dimen dimen; + + struct hashentry { + struct hashentry *next; + char *name; + Vardesc *vd; + }; + typedef struct hashentry hashentry; + + struct hashtab { + struct hashtab *next; + Namelist *nl; + int htsize; + hashentry *tab[1]; + }; + typedef struct hashtab hashtab; + + static hashtab *nl_cache; + static int n_nlcache; + static hashentry **zot; + static int colonseen; + extern ftnlen f__typesize[]; + + extern flag f__lquit; + extern int f__lcount, nml_read; + extern int t_getc(Void); + +#ifdef KR_headers + extern char *malloc(), *memset(); + +#ifdef ungetc + static int +un_getc(x,f__cf) int x; FILE *f__cf; +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc + extern int ungetc(); +#endif + +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef ungetc + static int +un_getc(int x, FILE *f__cf) +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + static Vardesc * +#ifdef KR_headers +hash(ht, s) hashtab *ht; register char *s; +#else +hash(hashtab *ht, register char *s) +#endif +{ + register int c, x; + register hashentry *h; + char *s0 = s; + + for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) + x += c; + for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) + if (!strcmp(s0, h->name)) + return h->vd; + return 0; + } + + hashtab * +#ifdef KR_headers +mk_hashtab(nl) Namelist *nl; +#else +mk_hashtab(Namelist *nl) +#endif +{ + int nht, nv; + hashtab *ht; + Vardesc *v, **vd, **vde; + hashentry *he; + + hashtab **x, **x0, *y; + for(x = &nl_cache; y = *x; x0 = x, x = &y->next) + if (nl == y->nl) + return y; + if (n_nlcache >= MAX_NL_CACHE) { + /* discard least recently used namelist hash table */ + y = *x0; + free((char *)y->next); + y->next = 0; + } + else + n_nlcache++; + nv = nl->nvars; + if (nv >= 0x4000) + nht = 0x7fff; + else { + for(nht = 1; nht < nv; nht <<= 1); + nht += nht - 1; + } + ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + + nv*sizeof(hashentry)); + if (!ht) + return 0; + he = (hashentry *)&ht->tab[nht]; + ht->nl = nl; + ht->htsize = nht; + ht->next = nl_cache; + nl_cache = ht; + memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); + vd = nl->vars; + vde = vd + nv; + while(vd < vde) { + v = *vd++; + if (!hash(ht, v->name)) { + he->next = *zot; + *zot = he; + he->name = v->name; + he->vd = v; + he++; + } + } + return ht; + } + +static char Alpha[256], Alphanum[256]; + + static VOID +nl_init(Void) { + register char *s; + register int c; + + if(!f__init) + f_init(); + for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) + Alpha[c] + = Alphanum[c] + = Alpha[c + 'a' - 'A'] + = Alphanum[c + 'a' - 'A'] + = c; + for(s = "0123456789_"; c = *s++; ) + Alphanum[c] = c; + } + +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +getname(s, slen) register char *s; int slen; +#else +getname(register char *s, int slen) +#endif +{ + register char *se = s + slen - 1; + register int ch; + + GETC(ch); + if (!(*s++ = Alpha[ch & 0xff])) { + if (ch != EOF) + ch = 115; + errfl(f__elist->cierr, ch, "namelist read"); + } + while(*s = Alphanum[GETC(ch) & 0xff]) + if (s < se) + s++; + if (ch == EOF) + err(f__elist->cierr, EOF, "namelist read"); + if (ch > ' ') + Ungetc(ch,f__cf); + return *s = 0; + } + + static int +#ifdef KR_headers +getnum(chp, val) int *chp; ftnlen *val; +#else +getnum(int *chp, ftnlen *val) +#endif +{ + register int ch, sign; + register ftnlen x; + + while(GETC(ch) <= ' ' && ch >= 0); + if (ch == '-') { + sign = 1; + GETC(ch); + } + else { + sign = 0; + if (ch == '+') + GETC(ch); + } + x = ch - '0'; + if (x < 0 || x > 9) + return 115; + while(GETC(ch) >= '0' && ch <= '9') + x = 10*x + ch - '0'; + while(ch <= ' ' && ch >= 0) + GETC(ch); + if (ch == EOF) + return EOF; + *val = sign ? -x : x; + *chp = ch; + return 0; + } + + static int +#ifdef KR_headers +getdimen(chp, d, delta, extent, x1) + int *chp; dimen *d; ftnlen delta, extent, *x1; +#else +getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +#endif +{ + register int k; + ftnlen x2, x3; + + if (k = getnum(chp, x1)) + return k; + x3 = 1; + if (*chp == ':') { + if (k = getnum(chp, &x2)) + return k; + x2 -= *x1; + if (*chp == ':') { + if (k = getnum(chp, &x3)) + return k; + if (!x3) + return 123; + x2 /= x3; + colonseen = 1; + } + if (x2 < 0 || x2 >= extent) + return 123; + d->extent = x2 + 1; + } + else + d->extent = 1; + d->curval = 0; + d->delta = delta; + d->stride = x3; + return 0; + } + +#ifndef No_Namelist_Questions + static Void +#ifdef KR_headers +print_ne(a) cilist *a; +#else +print_ne(cilist *a) +#endif +{ + flag intext = f__external; + int rpsave = f__recpos; + FILE *cfsave = f__cf; + unit *usave = f__curunit; + cilist t; + t = *a; + t.ciunit = 6; + s_wsne(&t); + fflush(f__cf); + f__external = intext; + f__reading = 1; + f__recpos = rpsave; + f__cf = cfsave; + f__curunit = usave; + f__elist = a; + } +#endif + + static char where0[] = "namelist read start "; + + int +#ifdef KR_headers +x_rsne(a) cilist *a; +#else +x_rsne(cilist *a) +#endif +{ + int ch, got1, k, n, nd, quote, readall; + Namelist *nl; + static char where[] = "namelist read"; + char buf[64]; + hashtab *ht; + Vardesc *v; + dimen *dn, *dn0, *dn1; + ftnlen *dims, *dims1; + ftnlen b, b0, b1, ex, no, nomax, size, span; + ftnint no1, no2, type; + char *vaddr; + long iva, ivae; + dimen dimens[MAXDIM], substr; + + if (!Alpha['a']) + nl_init(); + f__reading=1; + f__formatted=1; + got1 = 0; + top: + for(;;) switch(GETC(ch)) { + case EOF: + eof: + err(a->ciend,(EOF),where0); + case '&': + case '$': + goto have_amp; +#ifndef No_Namelist_Questions + case '?': + print_ne(a); + continue; +#endif + default: + if (ch <= ' ' && ch >= 0) + continue; +#ifndef No_Namelist_Comments + while(GETC(ch) != '\n') + if (ch == EOF) + goto eof; +#else + errfl(a->cierr, 115, where0); +#endif + } + have_amp: + if (ch = getname(buf,sizeof(buf))) + return ch; + nl = (Namelist *)a->cifmt; + if (strcmp(buf, nl->name)) +#ifdef No_Bad_Namelist_Skip + errfl(a->cierr, 118, where0); +#else + { + fprintf(stderr, + "Skipping namelist \"%s\": seeking namelist \"%s\".\n", + buf, nl->name); + fflush(stderr); + for(;;) switch(GETC(ch)) { + case EOF: + err(a->ciend, EOF, where0); + case '/': + case '&': + case '$': + if (f__external) + e_rsle(); + else + z_rnew(); + goto top; + case '"': + case '\'': + quote = ch; + more_quoted: + while(GETC(ch) != quote) + if (ch == EOF) + err(a->ciend, EOF, where0); + if (GETC(ch) == quote) + goto more_quoted; + Ungetc(ch,f__cf); + default: + continue; + } + } +#endif + ht = mk_hashtab(nl); + if (!ht) + errfl(f__elist->cierr, 113, where0); + for(;;) { + for(;;) switch(GETC(ch)) { + case EOF: + if (got1) + return 0; + err(a->ciend, EOF, where0); + case '/': + case '$': + case '&': + return 0; + default: + if (ch <= ' ' && ch >= 0 || ch == ',') + continue; + Ungetc(ch,f__cf); + if (ch = getname(buf,sizeof(buf))) + return ch; + goto havename; + } + havename: + v = hash(ht,buf); + if (!v) + errfl(a->cierr, 119, where); + while(GETC(ch) <= ' ' && ch >= 0); + vaddr = v->addr; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + ivae = size; + iva = readall = 0; + if (ch == '(' /*)*/ ) { + dn = dimens; + if (!(dims = v->dims)) { + if (type != TYCHAR) + errfl(a->cierr, 122, where); + if (k = getdimen(&ch, dn, (ftnlen)size, + (ftnlen)size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = dn->extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + goto scalar; + } + nd = (int)dims[0]; + nomax = span = dims[1]; + ivae = iva + size*nomax; + colonseen = 0; + if (k = getdimen(&ch, dn, size, nomax, &b)) + errfl(a->cierr, k, where); + no = dn->extent; + b0 = dims[2]; + dims1 = dims += 3; + ex = 1; + for(n = 1; n++ < nd; dims++) { + if (ch != ',') + errfl(a->cierr, 115, where); + dn1 = dn + 1; + span /= *dims; + if (k = getdimen(&ch, dn1, dn->delta**dims, + span, &b1)) + errfl(a->cierr, k, where); + ex *= *dims; + b += b1*ex; + no *= dn1->extent; + dn = dn1; + } + if (ch != ')') + errfl(a->cierr, 115, where); + readall = 1 - colonseen; + b -= b0; + if (b < 0 || b >= nomax) + errfl(a->cierr, 125, where); + iva += size * b; + dims = dims1; + while(GETC(ch) <= ' ' && ch >= 0); + no1 = 1; + dn0 = dimens; + if (type == TYCHAR && ch == '(' /*)*/) { + if (k = getdimen(&ch, &substr, size, size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = substr.extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + b0 = size; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + if (b1 < b0) + goto delta_adj; + } + if (readall) + goto delta_adj; + for(; dn0 < dn; dn0++) { + if (dn0->extent != *dims++ || dn0->stride != 1) + break; + no1 *= dn0->extent; + } + if (dn0 == dimens && dimens[0].stride == 1) { + no1 = dimens[0].extent; + dn0++; + } + delta_adj: + ex = 0; + for(dn1 = dn0; dn1 <= dn; dn1++) + ex += (dn1->extent-1) + * (dn1->delta *= dn1->stride); + for(dn1 = dn; dn1 > dn0; dn1--) { + ex -= (dn1->extent - 1) * dn1->delta; + dn1->delta -= ex; + } + } + else if (dims = v->dims) { + no = no1 = dims[1]; + ivae = iva + no*size; + } + else + scalar: + no = no1 = 1; + if (ch != '=') + errfl(a->cierr, 115, where); + got1 = nml_read = 1; + f__lcount = 0; + readloop: + for(;;) { + if (iva >= ivae || iva < 0) { + f__lquit = 1; + goto mustend; + } + else if (iva + no1*size > ivae) + no1 = (ivae - iva)/size; + f__lquit = 0; + if (k = l_read(&no1, vaddr + iva, size, type)) + return k; + if (f__lquit == 1) + return 0; + if (readall) { + iva += dn0->delta; + if (f__lcount > 0) { + no2 = (ivae - iva)/size; + if (no2 > f__lcount) + no2 = f__lcount; + if (k = l_read(&no2, vaddr + iva, + size, type)) + return k; + iva += no2 * dn0->delta; + } + } + mustend: + GETC(ch); + if (readall) + if (iva >= ivae) + readall = 0; + else for(;;) { + switch(ch) { + case ' ': + case '\t': + case '\n': + GETC(ch); + continue; + } + break; + } + if (ch == '/' || ch == '$' || ch == '&') { + f__lquit = 1; + return 0; + } + else if (f__lquit) { + while(ch <= ' ' && ch >= 0) + GETC(ch); + Ungetc(ch,f__cf); + if (!Alpha[ch & 0xff] && ch >= 0) + errfl(a->cierr, 125, where); + break; + } + Ungetc(ch,f__cf); + if (readall && !Alpha[ch & 0xff]) + goto readloop; + if ((no -= no1) <= 0) + break; + for(dn1 = dn0; dn1 <= dn; dn1++) { + if (++dn1->curval < dn1->extent) { + iva += dn1->delta; + goto readloop; + } + dn1->curval = 0; + } + break; + } + } + } + + integer +#ifdef KR_headers +s_rsne(a) cilist *a; +#else +s_rsne(cilist *a) +#endif +{ + extern int l_eof; + int n; + + f__external=1; + l_eof = 0; + if(n = c_le(a)) + return n; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,where0); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + n = x_rsne(a); + nml_read = 0; + if (n) + return n; + return e_rsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c new file mode 100644 index 00000000000..5bf8a628ac0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c @@ -0,0 +1,86 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + +#include "f2c.h" +#ifndef NO_OVERWRITE +#include "stdio.h" +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void exit_(); +#else +#undef min +#undef max +#include "stdlib.h" +extern +#ifdef __cplusplus + "C" +#endif + char *F77_aloc(ftnlen, char*); +#endif +#include "string.h" +#endif /* NO_OVERWRITE */ + +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; +#else +s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c new file mode 100644 index 00000000000..3a2ea67ddf0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* compare two strings */ + +#ifdef KR_headers +integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +#else +integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ +register unsigned char *a, *aend, *b, *bend; +a = (unsigned char *)a0; +b = (unsigned char *)b0; +aend = a + la; +bend = b + lb; + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + +else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c new file mode 100644 index 00000000000..9dacfc7d8d2 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c @@ -0,0 +1,57 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +#else +void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c new file mode 100644 index 00000000000..51d80eb0878 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c @@ -0,0 +1,96 @@ +#include "stdio.h" +#include "f2c.h" +#define PAUSESIG 15 + +#include "signal1.h" +#ifdef KR_headers +#define Void /* void */ +#define Int /* int */ +#else +#define Void void +#define Int int +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern int getpid(void), isatty(int), pause(void); +#endif + +extern VOID f_exit(Void); + +#ifndef MSDOS + static VOID +waitpause(Sigarg) +{ Use_Sigarg; + return; + } +#endif + + static VOID +#ifdef KR_headers +s_1paus(fin) FILE *fin; +#else +s_1paus(FILE *fin) +#endif +{ + fprintf(stderr, + "To resume execution, type go. Other input will terminate the job.\n"); + fflush(stderr); + if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { + fprintf(stderr, "STOP\n"); +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + } + } + + int +#ifdef KR_headers +s_paus(s, n) char *s; ftnlen n; +#else +s_paus(char *s, ftnlen n) +#endif +{ + fprintf(stderr, "PAUSE "); + if(n > 0) + fprintf(stderr, " %.*s", (int)n, s); + fprintf(stderr, " statement executed\n"); + if( isatty(fileno(stdin)) ) + s_1paus(stdin); + else { +#ifdef MSDOS + FILE *fin; + fin = fopen("con", "r"); + if (!fin) { + fprintf(stderr, "s_paus: can't open con!\n"); + fflush(stderr); + exit(1); + } + s_1paus(fin); + fclose(fin); +#else + fprintf(stderr, + "To resume execution, execute a kill -%d %d command\n", + PAUSESIG, getpid() ); + signal1(PAUSESIG, waitpause); + fflush(stderr); + pause(); +#endif + } + fprintf(stderr, "Execution resumes after PAUSE.\n"); + fflush(stderr); + return 0; /* NOT REACHED */ +#ifdef __cplusplus + } +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c new file mode 100644 index 00000000000..5c12b949634 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c @@ -0,0 +1,32 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* called when a subscript is out of range */ + +#ifdef KR_headers +extern VOID sig_die(); +integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +#else +extern VOID sig_die(char*,int); +integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +#endif +{ +register int i; + +fprintf(stderr, "Subscript out of range on file line %ld, procedure ", + (long)line); +while((i = *procn) && i != '_' && i != ' ') + putc(*procn++, stderr); +fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", + (long)offset+1); +while((i = *varn) && i != ' ') + putc(*varn++, stderr); +sig_die(".", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c new file mode 100644 index 00000000000..68233aea7e3 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c @@ -0,0 +1,48 @@ +#include "stdio.h" +#include "f2c.h" + +#ifdef KR_headers +extern void f_exit(); +int s_stop(s, n) char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +void f_exit(void); + +int s_stop(char *s, ftnlen n) +#endif +{ +int i; + +if(n > 0) + { + fprintf(stderr, "STOP "); + for(i = 0; iciunit]; + if(a->ciunit >= MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") + if(!p->ufmt) err(a->cierr,102,"sfe") + return(0); +} +integer e_wsfe(Void) +{ + int n = en_fio(); + f__fmtbuf = NULL; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c new file mode 100644 index 00000000000..8c22cd58113 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c @@ -0,0 +1,51 @@ +#include "stdio.h" +#include "signal.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifdef KR_headers +void sig_die(s, kill) register char *s; int kill; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif + extern void f_exit(void); + +void sig_die(register char *s, int kill) +#endif +{ + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) + { + fflush(stderr); + f_exit(); + fflush(stderr); + /* now get a core */ +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); +#endif + abort(); + } + else { +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(1); + } + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h new file mode 100644 index 00000000000..a383774b82d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h @@ -0,0 +1,35 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ + +#include + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) + +#ifdef __cplusplus +#define Sigarg ... +#define Use_Sigarg +#else +#define Sigarg Int n +#define Use_Sigarg n = n /* shut up compiler warning */ +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c new file mode 100644 index 00000000000..3b0e6cfe98b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c @@ -0,0 +1,21 @@ +#include "f2c.h" +#include "signal1.h" +#ifdef __cplusplus +extern "C" { +#endif + + ftnint +#ifdef KR_headers +signal_(sigp, proc) integer *sigp; sig_pf proc; +#else +signal_(integer *sigp, sig_pf proc) +#endif +{ + int sig; + sig = (int)*sigp; + + return (ftnint)signal(sig, proc); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c new file mode 100644 index 00000000000..de95a3b70fd --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c @@ -0,0 +1,24 @@ +#include "arith.h" + +#ifndef Long +#define Long long +#endif + + int +#ifdef KR_headers +signbit_f2c(x) double *x; +#else +signbit_f2c(double *x) +#endif +{ +#ifdef IEEE_MC68k + if (*(Long*)x & 0x80000000) + return 1; +#else +#ifdef IEEE_8087 + if (((Long*)x)[1] & 0x80000000) + return 1; +#endif /*IEEE_8087*/ +#endif /*IEEE_MC68k*/ + return 0; + } diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c new file mode 100644 index 00000000000..191e32627cc --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c @@ -0,0 +1,90 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern uiolen f__reclen; +OFF_T f__recloc; + + int +#ifdef KR_headers +c_sue(a) cilist *a; +#else +c_sue(cilist *a) +#endif +{ + f__external=f__sequential=1; + f__formatted=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit >= MXUNIT || a->ciunit < 0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) + err(a->cierr,114,"sue"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,103,"sue") + if(!f__curunit->useek) err(a->cierr,103,"sue") + return(0); +} +#ifdef KR_headers +integer s_rsue(a) cilist *a; +#else +integer s_rsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_sue(a)) return(n); + f__recpos=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr, errno, "read start"); + if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) + != 1) + { if(feof(f__cf)) + { f__curunit->uend = 1; + err(a->ciend, EOF, "start"); + } + clearerr(f__cf); + err(a->cierr, errno, "start"); + } + return(0); +} +#ifdef KR_headers +integer s_wsue(a) cilist *a; +#else +integer s_wsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + if(n=c_sue(a)) return(n); + f__reading=0; + f__reclen=0; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "write start"); + f__recloc=FTELL(f__cf); + FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); + return(0); +} +integer e_wsue(Void) +{ OFF_T loc; + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + loc=FTELL(f__cf); + FSEEK(f__cf,f__recloc,SEEK_SET); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + FSEEK(f__cf,loc,SEEK_SET); + return(0); +} +integer e_rsue(Void) +{ + FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h new file mode 100644 index 00000000000..4c026a240a1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h @@ -0,0 +1,66 @@ +#ifndef SYSDEP_H_INCLUDED +#define SYSDEP_H_INCLUDED +#undef USE_LARGEFILE +#ifndef NO_LONG_LONG + +#ifdef __sun__ +#define USE_LARGEFILE +#define OFF_T off64_t +#endif + +#ifdef __linux__ +#define USE_LARGEFILE +#define OFF_T __off64_t +#endif + +#ifdef _AIX43 +#define _LARGE_FILES +#define _LARGE_FILE_API +#define USE_LARGEFILE +#endif /*_AIX43*/ + +#ifdef __hpux +#define _FILE64 +#define _LARGEFILE64_SOURCE +#define USE_LARGEFILE +#endif /*__hpux*/ + +#ifdef __sgi +#define USE_LARGEFILE +#endif /*__sgi*/ + +#ifdef __FreeBSD__ +#define OFF_T off_t +#define FSEEK fseeko +#define FTELL ftello +#endif + +#ifdef USE_LARGEFILE +#ifndef OFF_T +#define OFF_T off64_t +#endif +#define _LARGEFILE_SOURCE +#define _LARGEFILE64_SOURCE +#include +#include +#define FOPEN fopen64 +#define FREOPEN freopen64 +#define FSEEK fseeko64 +#define FSTAT fstat64 +#define FTELL ftello64 +#define FTRUNCATE ftruncate64 +#define STAT stat64 +#define STAT_ST stat64 +#endif /*USE_LARGEFILE*/ +#endif /*NO_LONG_LONG*/ + +#ifndef NON_UNIX_STDIO +#ifndef USE_LARGEFILE +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/stat.h" +#endif +#endif + +#endif /*SYSDEP_H_INCLUDED*/ diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c new file mode 100644 index 00000000000..3220bfb5c2d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c @@ -0,0 +1,42 @@ +/* f77 interface to system routine */ + +#include "f2c.h" + +#ifdef KR_headers +extern char *F77_aloc(); + + integer +system_(s, n) register char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, char*); + + integer +system_(register char *s, ftnlen n) +#endif +{ + char buff0[256], *buff; + register char *bp, *blast; + integer rv; + + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; + + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c new file mode 100644 index 00000000000..39097f46991 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), + sizeof(real), sizeof(doublereal), + sizeof(complex), sizeof(doublecomplex), + sizeof(logical), sizeof(char), + 0, sizeof(integer1), + sizeof(logical1), sizeof(shortlogical), +#ifdef Allow_TYQUAD + sizeof(longint), +#endif + 0}; +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c new file mode 100644 index 00000000000..44f768d9a24 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c @@ -0,0 +1,75 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +uiolen f__reclen; + + int +#ifdef KR_headers +do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +do_us(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__reading) + { + f__recpos += (int)(*number * len); + if(f__recpos>f__reclen) + err(f__elist->cierr, 110, "do_us"); + if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->ciend, EOF, "do_us"); + return(0); + } + else + { + f__reclen += *number * len; + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); + } +} +#ifdef KR_headers +integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_ud(ftnint *number, char *ptr, ftnlen len) +#endif +{ + f__recpos += (int)(*number * len); + if(f__recpos > f__curunit->url && f__curunit->url!=1) + err(f__elist->cierr,110,"do_ud"); + if(f__reading) + { +#ifdef Pad_UDread +#ifdef KR_headers + int i; +#else + size_t i; +#endif + if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) + && !(f__recpos - *number*len)) + err(f__elist->cierr,EOF,"do_ud") + if (i < *number) + memset(ptr + i*len, 0, (*number - i)*len); + return 0; +#else + if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->cierr,EOF,"do_ud") + else return(0); +#endif + } + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); +} +#ifdef KR_headers +integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_uio(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__sequential) + return(do_us(number,ptr,len)); + else return(do_ud(number,ptr,len)); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c new file mode 100644 index 00000000000..794cd6adee0 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c @@ -0,0 +1,368 @@ +#include +#include +#include "arith.h" + +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYINT1 11 +#define TYQUAD 14 +#ifndef Long +#define Long long +#endif + +#ifdef __mips +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifdef _PA_RISC1_1 +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifndef RNAN +#define RNAN 0xff800001 +#ifdef IEEE_MC68k +#define DNAN0 0xfff00000 +#define DNAN1 1 +#else +#define DNAN0 1 +#define DNAN1 0xfff00000 +#endif +#endif /*RNAN*/ + +#ifdef KR_headers +#define Void /*void*/ +#define FA7UL (unsigned Long) 0xfa7a7a7aL +#else +#define Void void +#define FA7UL 0xfa7a7a7aUL +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +static void ieee0(Void); + +static unsigned Long rnan = RNAN, + dnan0 = DNAN0, + dnan1 = DNAN1; + +double _0 = 0.; + + void +#ifdef KR_headers +_uninit_f2c(x, type, len) void *x; int type; long len; +#else +_uninit_f2c(void *x, int type, long len) +#endif +{ + static int first = 1; + + unsigned Long *lx, *lxe; + + if (first) { + first = 0; + ieee0(); + } + if (len == 1) + switch(type) { + case TYINT1: + *(char*)x = 'Z'; + return; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYLONG: + *(unsigned Long*)x = FA7UL; + return; + case TYQUAD: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + case TYREAL: + *(unsigned Long*)x = rnan; + return; + case TYDREAL: + lx = (unsigned Long*)x; + lx[0] = dnan0; + lx[1] = dnan1; + return; + default: + printf("Surprise type %d in _uninit_f2c\n", type); + } + switch(type) { + case TYINT1: + memset(x, 'Z', len); + break; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYQUAD: + len *= 2; + /* no break */ + case TYLONG: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = FA7UL; + break; + case TYCOMPLEX: + len *= 2; + /* no break */ + case TYREAL: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = rnan; + break; + case TYDCOMPLEX: + len *= 2; + /* no break */ + case TYDREAL: + lx = (unsigned Long*)x; + for(lxe = lx + 2*len; lx < lxe; lx += 2) { + lx[0] = dnan0; + lx[1] = dnan1; + } + } + } +#ifdef __cplusplus +} +#endif + +#ifndef MSpc +#ifdef MSDOS +#define MSpc +#else +#ifdef _WIN32 +#define MSpc +#endif +#endif +#endif + +#ifdef MSpc +#define IEEE0_done +#include "float.h" +#include "signal.h" + + static void +ieee0(Void) +{ +#ifndef __alpha +#ifndef EM_DENORMAL +#define EM_DENORMAL _EM_DENORMAL +#endif +#ifndef EM_UNDERFLOW +#define EM_UNDERFLOW _EM_UNDERFLOW +#endif +#ifndef EM_INEXACT +#define EM_INEXACT _EM_INEXACT +#endif +#ifndef MCW_EM +#define MCW_EM _MCW_EM +#endif + _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); +#endif + /* With MS VC++, compiling and linking with -Zi will permit */ + /* clicking to invoke the MS C++ debugger, which will show */ + /* the point of error -- provided SIGFPE is SIG_DFL. */ + signal(SIGFPE, SIG_DFL); + } +#endif /* MSpc */ + +#ifdef __mips /* must link with -lfpe */ +#define IEEE0_done +/* code from Eric Grosse */ +#include +#include +#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ +#include "/usr/include/sys/fpu.h" + + static void +#ifdef KR_headers +ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; +#else +ieeeuserhand(unsigned exception[5], int val[2]) +#endif +{ + fflush(stdout); + fprintf(stderr,"ieee0() aborting because of "); + if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); + else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); + else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); + else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); + else fprintf(stderr,"\tunknown reason\n"); + fflush(stderr); + abort(); +} + + static void +#ifdef KR_headers +ieeeuserhand2(j) unsigned int **j; +#else +ieeeuserhand2(unsigned int **j) +#endif +{ + fprintf(stderr,"ieee0() aborting because of confusion\n"); + abort(); +} + + static void +ieee0(Void) +{ + int i; + for(i=1; i<=4; i++){ + sigfpe_[i].count = 1000; + sigfpe_[i].trace = 1; + sigfpe_[i].repls = _USER_DETERMINED; + } + sigfpe_[1].repls = _ZERO; /* underflow */ + handle_sigfpes( _ON, + _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, + ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); + } +#endif /* mips */ + +#ifdef __linux__ +#define IEEE0_done +#include "fpu_control.h" + +#ifdef __alpha__ +#ifndef USE_setfpucw +#define __setfpucw(x) __fpu_control = (x) +#endif +#endif + +#ifndef _FPU_SETCW +#undef Can_use__setfpucw +#define Can_use__setfpucw +#endif + + static void +ieee0(Void) +{ +#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) +/* Reported 20010705 by Alan Bain */ +/* Note that IEEE 754 IOP (illegal operation) */ +/* = Signaling NAN (SNAN) + operation error (OPERR). */ +#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ + __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); +#else + __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; + _FPU_SETCW(__fpu_control); +#endif + +#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ +/* Reported 20011109 by Alan Bain */ + +#ifdef Can_use__setfpucw + +/* The following is NOT a mistake -- the author of the fpu_control.h +for the PPC has erroneously defined IEEE mode to turn on exceptions +other than Inexact! Start from default then and turn on only the ones +which we want*/ + + __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); + +#else /* PPC && !Can_use__setfpucw */ + + __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; + _FPU_SETCW(__fpu_control); + +#endif /*Can_use__setfpucw*/ + +#else /* !(mc68000||powerpc) */ + +#ifdef _FPU_IEEE +#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ +#define _FPU_EXTENDED 0 +#endif +#ifndef _FPU_DOUBLE +#define _FPU_DOUBLE 0 +#endif +#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ + __setfpucw(_FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); +#else + __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; + _FPU_SETCW(__fpu_control); +#endif + +#else /* !_FPU_IEEE */ + + fprintf(stderr, "\n%s\n%s\n%s\n%s\n", + "WARNING: _uninit_f2c in libf2c does not know how", + "to enable trapping on this system, so f2c's -trapuv", + "option will not detect uninitialized variables unless", + "you can enable trapping manually."); + fflush(stderr); + +#endif /* _FPU_IEEE */ +#endif /* __mc68k__ */ + } +#endif /* __linux__ */ + +#ifdef __alpha +#ifndef IEEE0_done +#define IEEE0_done +#include + static void +ieee0(Void) +{ + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); + } +#endif /*IEEE0_done*/ +#endif /*__alpha*/ + +#ifdef __hpux +#define IEEE0_done +#define _INCLUDE_HPUX_SOURCE +#include + +#ifndef FP_X_INV +#include +#define fpsetmask fesettrapenable +#define FP_X_INV FE_INVALID +#endif + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__hpux*/ + +#ifdef _AIX +#define IEEE0_done +#include + + static void +ieee0(Void) +{ + fp_enable(TRP_INVALID); + fp_trap(FP_TRAP_SYNC); + } +#endif /*_AIX*/ + +#ifdef __sun +#define IEEE0_done +#include + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__sparc*/ + +#ifndef IEEE0_done + static void +ieee0(Void) {} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c new file mode 100644 index 00000000000..f4b3aef2ce7 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c @@ -0,0 +1,54 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +g_char(a,alen,b) char *a,*b; ftnlen alen; +#else +g_char(char *a, ftnlen alen, char *b) +#endif +{ + char *x = a + alen, *y = b + alen; + + for(;; y--) { + if (x <= a) { + *b = 0; + return; + } + if (*--x != ' ') + break; + } + *y-- = 0; + do *y-- = *x; + while(x-- > a); + } + + VOID +#ifdef KR_headers +b_char(a,b,blen) char *a,*b; ftnlen blen; +#else +b_char(char *a, char *b, ftnlen blen) +#endif +{ int i; + for(i=0;i= d + 2 || f__scale <= -d) + goto nogood; + } + if(f__scale <= 0) + --d; + if (len == sizeof(real)) + dd = p->pf; + else + dd = p->pd; + if (dd < 0.) { + signspace = sign = 1; + dd = -dd; + } + else { + sign = 0; + signspace = (int)f__cplus; +#ifndef VAX + if (!dd) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&dd)) + signspace = sign = 1; +#endif + dd = 0.; /* avoid -0 */ + } +#endif + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) { + delta--; + insert0 = 1; + } + else +#endif + if (delta < 0) { +nogood: + while(--w >= 0) + PUT('*'); + return(0); + } + if (f__scale < 0) + d += f__scale; + if (d > FMAX) { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf(buf,"%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit(buf[0])) { + switch(buf[0]) { + case 'n': + case 'N': + signspace = 0; /* no sign for NaNs */ + } + delta = w - strlen(buf) - signspace; + if (delta < 0) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + for(s = buf; *s; s++) + PUT(*s); + return 0; + } +#endif + se = buf + d + 3; +#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ + if (f__scale != 1 && dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +#else + if (dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); + else + strcpy(se, "+00"); +#endif + s = ++se; + if (e < 2) { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) { +#ifdef Pedantic + if (!e0 && !s[3]) + for(s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) { + for(s -= 2, e1 = 2; s[0] = s[1]; s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for(s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + s = buf; + i = f__scale; + if (f__scale <= 0) { +#ifdef WANT_LEAD_0 + if (insert0) + PUT('0'); +#endif + PUT('.'); + for(; i < 0; ++i) + PUT('0'); + PUT(*s); + s += 2; + } + else if (f__scale > 1) { + PUT(*s); + s += 2; + while(--i > 0) + PUT(*s++); + PUT('.'); + } + if (d1) { + se -= 2; + while(s < se) PUT(*s++); + se += 2; + do PUT('0'); while(--d1 > 0); + } + while(s < se) + PUT(*s++); + if (e < 2) + PUT(s[1]); + else { + while(++e1 <= e) + PUT('0'); + while(*s) + PUT(*s++); + } + return 0; + } + + int +#ifdef KR_headers +wrt_F(p,w,d,len) ufloat *p; ftnlen len; +#else +wrt_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; + + x= (len==sizeof(real)?p->pf:p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { x = -x; sign = 1; } + else { + sign = 0; +#ifndef VAX + if (!x) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&x)) + sign = 2; +#endif + x = 0.; + } +#endif + } + + if (n = f__scale) + if (n > 0) + do x *= 10.; while(--n > 0); + else + do x *= 0.1; while(++n < 0); + +#ifdef USE_STRLEN + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +#else + n = sprintf(b = buf, "%#.*f", d, x) + d1; +#endif + +#ifndef WANT_LEAD_0 + if (buf[0] == '0' && d) + { ++b; --n; } +#endif + if (sign == 1) { + /* check for all zeros */ + for(s = b;;) { + while(*s == '0') s++; + switch(*s) { + case '.': + s++; continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || f__cplus) + ++n; + if (n > w) { +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while(--w >= 0) + PUT('*'); + return 0; + } + } + for(w -= n; --w >= 0; ) + PUT(' '); + if (sign) + PUT('-'); + else if (f__cplus) + PUT('+'); + while(n = *b++) + PUT(n); + while(--d1 >= 0) + PUT('0'); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c new file mode 100644 index 00000000000..a970db95910 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c @@ -0,0 +1,377 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + +extern icilist *f__svic; +extern char *f__icptr; + + static int +mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ + /* instead we know too much about stdio */ +{ + int cursor = f__cursor; + f__cursor = 0; + if(f__external == 0) { + if(cursor < 0) { + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + f__icptr += cursor; + if(f__recpos < 0) + err(f__elist->cierr, 110, "left off"); + } + else if(cursor > 0) { + if(f__recpos + cursor >= f__svic->icirlen) + err(f__elist->cierr, 110, "recend"); + if(f__hiwater <= f__recpos) + for(; cursor > 0; cursor--) + (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__icptr += cursor; + f__recpos += cursor; + } + } + return(0); + } + if (cursor > 0) { + if(f__hiwater <= f__recpos) + for(;cursor>0;cursor--) (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__recpos += cursor; + } + } + else if (cursor < 0) + { + if(cursor + f__recpos < 0) + err(f__elist->cierr,110,"left off"); + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + } + return(0); +} + + static int +#ifdef KR_headers +wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +#else +wrt_Z(Uint *n, int w, int minlen, ftnlen len) +#endif +{ + register char *s, *se; + register int i, w1; + static int one = 1; + static char hex[] = "0123456789ABCDEF"; + s = (char *)n; + --len; + if (*(char *)&one) { + /* little endian */ + se = s; + s += len; + i = -1; + } + else { + se = s + len; + i = 1; + } + for(;; s += i) + if (s == se || *s) + break; + w1 = (i*(se-s) << 1) + 1; + if (*s & 0xf0) + w1++; + if (w1 > w) + for(i = 0; i < w; i++) + (*f__putn)('*'); + else { + if ((minlen -= w1) > 0) + w1 += minlen; + while(--w >= w1) + (*f__putn)(' '); + while(--minlen >= 0) + (*f__putn)('0'); + if (!(*s & 0xf0)) { + (*f__putn)(hex[*s & 0xf]); + if (s == se) + return 0; + s += i; + } + for(;; s += i) { + (*f__putn)(hex[*s >> 4 & 0xf]); + (*f__putn)(hex[*s & 0xf]); + if (s == se) + break; + } + } + return 0; + } + + static int +#ifdef KR_headers +wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +#else +wrt_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ int ndigit,sign,spare,i; + longint x; + char *ans; + if(len==sizeof(integer)) x=n->il; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + spare=w-ndigit; + if(sign || f__cplus) spare--; + if(spare<0) + for(i=0;iil; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + if(sign || f__cplus) xsign=1; + else xsign=0; + if(ndigit+xsign>w || m+xsign>w) + { for(i=0;i=m) + spare=w-ndigit-xsign; + else + spare=w-m-xsign; + for(i=0;iil; + else if(sz == sizeof(char)) x = n->ic; + else x=n->is; + for(i=0;i 0) (*f__putn)(*p++); + return(0); +} + static int +#ifdef KR_headers +wrt_AW(p,w,len) char * p; ftnlen len; +#else +wrt_AW(char * p, int w, ftnlen len) +#endif +{ + while(w>len) + { w--; + (*f__putn)(' '); + } + while(w-- > 0) + (*f__putn)(*p++); + return(0); +} + + static int +#ifdef KR_headers +wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ double up = 1,x; + int i=0,oldscale,n,j; + x = len==sizeof(real)?p->pf:p->pd; + if(x < 0 ) x = -x; + if(x<.1) { + if (x != 0.) + return(wrt_E(p,w,d,e,len)); + i = 1; + goto have_i; + } + for(;i<=d;i++,up*=10) + { if(x>=up) continue; + have_i: + oldscale = f__scale; + f__scale = 0; + if(e==0) n=4; + else n=e+2; + i=wrt_F(p,w-n,d-i,len); + for(j=0;jop) + { + default: + fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); + case IM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); + case OM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); + case L: return(wrt_L((Uint *)ptr,p->p1, len)); + case A: return(wrt_A(ptr,len)); + case AW: + return(wrt_AW(ptr,p->p1,len)); + case D: + case E: + case EE: + return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case G: + case GE: + return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); + + /* Z and ZM assume 8-bit bytes. */ + + case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); + case ZM: + return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); + } +} + + int +#ifdef KR_headers +w_ned(p) struct syl *p; +#else +w_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case SLASH: + return((*f__donewrec)()); + case T: f__cursor = p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + case TR: + case X: + f__cursor += p->p1; + return(1); + case APOS: + return(wrt_AP(p->p2.s)); + case H: + return(wrt_H(p->p1,p->p2.s)); + } +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c new file mode 100644 index 00000000000..8709f3b3479 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c @@ -0,0 +1,78 @@ +/*write sequential formatted external*/ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +x_wSL(Void) +{ + int n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return(n == 0); +} + + static int +xw_end(Void) +{ + int n; + + if(f__nonl) { + f__putbuf(n = 0); + fflush(f__cf); + } + else + n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + + static int +xw_rev(Void) +{ + int n = 0; + if(f__workdone) { + n = f__putbuf('\n'); + f__workdone = 0; + } + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + +#ifdef KR_headers +integer s_wsfe(a) cilist *a; /*start*/ +#else +integer s_wsfe(cilist *a) /*start*/ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=0; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__hiwater = f__cursor=f__recpos=0; + f__nonl = 0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__putn= x_putc; + f__doed= w_ed; + f__doned= w_ned; + f__doend=xw_end; + f__dorevert=xw_rev; + f__donewrec=x_wSL; + fmt_bg(); + f__cplus=0; + f__cblank=f__curunit->ublnk; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c new file mode 100644 index 00000000000..3e602702c0c --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c @@ -0,0 +1,42 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer s_wsle(a) cilist *a; +#else +integer s_wsle(cilist *a) +#endif +{ + int n; + if(n=c_le(a)) return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + f__lioproc = l_write; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "list output start"); + return(0); + } + +integer e_wsle(Void) +{ + int n = f__putbuf('\n'); + f__recpos=0; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return(n); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c new file mode 100644 index 00000000000..e204a51a4f1 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +s_wsne(a) cilist *a; +#else +s_wsne(cilist *a) +#endif +{ + int n; + + if(n=c_le(a)) + return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "namelist output start"); + x_wsne(a); + return e_wsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c new file mode 100644 index 00000000000..f810d3edbfe --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" + +extern int f__Aquote; + + static VOID +nl_donewrec(Void) +{ + (*f__donewrec)(); + PUT(' '); + } + +#ifdef KR_headers +x_wsne(a) cilist *a; +#else +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +x_wsne(cilist *a) +#endif +{ + Namelist *nl; + char *s; + Vardesc *v, **vd, **vde; + ftnint number, type; + ftnlen *dims; + ftnlen size; + extern ftnlen f__typesize[]; + + nl = (Namelist *)a->cifmt; + PUT('&'); + for(s = nl->name; *s; s++) + PUT(*s); + PUT(' '); + f__Aquote = 1; + vd = nl->vars; + vde = vd + nl->nvars; + while(vd < vde) { + v = *vd++; + s = v->name; +#ifdef No_Extra_Namelist_Newlines + if (f__recpos+strlen(s)+2 >= L_len) +#endif + nl_donewrec(); + while(*s) + PUT(*s++); + PUT(' '); + PUT('='); + number = (dims = v->dims) ? dims[1] : 1; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + l_write(&number, v->addr, size, type); + if (vd < vde) { + if (f__recpos+2 >= L_len) + nl_donewrec(); + PUT(','); + PUT(' '); + } + else if (f__recpos+1 >= L_len) + nl_donewrec(); + } + f__Aquote = 0; + PUT('/'); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c new file mode 100644 index 00000000000..4d8a015d384 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double f__cabs(); +double z_abs(z) doublecomplex *z; +#else +double f__cabs(double, double); +double z_abs(doublecomplex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c new file mode 100644 index 00000000000..4abe8bf8820 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_cos(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_cos(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c new file mode 100644 index 00000000000..b61f03b8efc --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID z_div(c, a, b) doublecomplex *a, *b, *c; +#else +extern void sig_die(char*, int); +void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + if (a->i != 0 || a->r != 0) + abi = 1.; + c->i = c->r = abi / abr; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c new file mode 100644 index 00000000000..7b8edfece03 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(), cos(), sin(); +VOID z_exp(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_exp(doublecomplex *r, doublecomplex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c new file mode 100644 index 00000000000..4f11bbe0c78 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c @@ -0,0 +1,121 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), f__cabs(), atan2(); +#define ANSI(x) () +#else +#define ANSI(x) x +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +#endif + +#ifndef NO_DOUBLE_EXTENDED +#ifndef GCC_COMPARE_BUG_FIXED +#ifndef Pre20000310 +#ifdef Comment +Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: +on IA32 (Intel 80x87) systems, they may do comparisons on values computed +in extended-precision registers. This can lead to the test "s > s0" that +was used below being carried out incorrectly. The fix below cannot be +spoiled by overzealous optimization, since the compiler cannot know +whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always +to be zero. The weird name is unlikely to collide with anything.) + +An example (provided by Ulrich Jakobus) where the bug fix matters is + + double complex a, b + a = (.1099557428756427618354862829619, .9857360542953131909982289471372) + b = log(a) + +An alternative to the fix below would be to use 53-bit rounding precision, +but the means of specifying this 80x87 feature are highly unportable. +#endif /*Comment*/ +#define BYPASS_GCC_COMPARE_BUG +double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); + static double +#ifdef KR_headers +diff1(a,b) double *a, *b; +#else +diff1(double *a, double *b) +#endif +{ return *a - *b; } +#endif /*Pre20000310*/ +#endif /*GCC_COMPARE_BUG_FIXED*/ +#endif /*NO_DOUBLE_EXTENDED*/ + +#ifdef KR_headers +VOID z_log(r, z) doublecomplex *r, *z; +#else +void z_log(doublecomplex *r, doublecomplex *z) +#endif +{ + double s, s0, t, t2, u, v; + double zi = z->i, zr = z->r; +#ifdef BYPASS_GCC_COMPARE_BUG + double (*diff) ANSI((double*,double*)); +#endif + + r->i = atan2(zi, zr); +#ifdef Pre20000310 + r->r = log( f__cabs( zr, zi ) ); +#else + if (zi < 0) + zi = -zi; + if (zr < 0) + zr = -zr; + if (zr < zi) { + t = zi; + zi = zr; + zr = t; + } + t = zi/zr; + s = zr * sqrt(1 + t*t); + /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ + if ((t = s - 1) < 0) + t = -t; + if (t > .01) + r->r = log(s); + else { + +#ifdef Comment + + log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... + + = x(1 - x/2 + x^2/3 -+...) + + [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so + + sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] + +#endif /*Comment*/ + +#ifdef BYPASS_GCC_COMPARE_BUG + if (!(diff = gcc_bug_bypass_diff_F2C)) + diff = diff1; +#endif + t = ((zr*zr - 1.) + zi*zi) / (s + 1); + t2 = t*t; + s = 1. - 0.5*t; + u = v = 1; + do { + s0 = s; + u *= t2; + v += 2; + s += u/v - t*u/(v+1); + } +#ifdef BYPASS_GCC_COMPARE_BUG + while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); +#else + while(s > s0); +#endif + r->r = s*t; + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c new file mode 100644 index 00000000000..01225a9448d --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_sin(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_sin(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c new file mode 100644 index 00000000000..35bd44c8e08 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c @@ -0,0 +1,35 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(), f__cabs(); +VOID z_sqrt(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +void z_sqrt(doublecomplex *r, doublecomplex *z) +#endif +{ + double mag, zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = sqrt(0.5 * (mag + zr) ); + r->i = zi / r->r / 2; + } + else + { + r->i = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + r->i = - r->i; + r->r = zi / r->i / 2; + } + } +#ifdef __cplusplus +} +#endif diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmx.test b/Build/source/utils/pmx/pmx-2.6.18/pmx.test new file mode 100755 index 00000000000..e2c9915fdb7 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/pmx.test @@ -0,0 +1,25 @@ +#! /bin/sh + +# Copyright (C) 2012 Peter Breitenlohner +# You may freely use, modify and/or distribute this file. + +rm -f barsant* pmxaerr.dat + +cp $srcdir/tests/barsant.pmx . + +failed= + +./scor2prt barsant \ + && diff barsant1.pmx $srcdir/tests/barsant1.pmx \ + && diff barsant2.pmx $srcdir/tests/barsant2.pmx \ + || failed="$failed scor2prt" + +./pmxab barsant \ + && diff barsant.mid $srcdir/tests/barsant.mid \ + && diff barsant.pml $srcdir/tests/barsant.pml \ + && diff barsant.tex $srcdir/tests/barsant.tex \ + || failed="$failed pmxab" + +test -z "$failed" && exit 0 +echo "failed tests:$failed" +exit 1 diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f b/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f new file mode 100644 index 00000000000..09b5ec6e0dc --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f @@ -0,0 +1,23597 @@ + program pmxab +c +c This program, PMX, developed by Don Simons +c (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with +c MusiXTeX and TeX, its purpose is to allow the user to create high-quality +c typeset musical scores by including a sequence of PMX commands in an ASCII +c input file. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c + character*9 date + character*5 version,versionc + common /comver/ versionc +c +c To compile with gfortran: +c 1. Merge all files using copy *.for epmx[nnnn].for +c 2. Search and replace all character*65536 with character*131072 +c 3. Comment/uncomment getarg lines +c 4. gfortran -O pmx[nnnn].for -o pmxab.exe +c +c To do +c Correct Rainer's email address in manual +c Linesplit (\\) in h +c Tt at start of a movement. +c Toggle midi on or off; allow midi only. +c Page number printed on 1st page even if 1 system. +c Still need inserted space for chordal accidentals +c Voicewise transposition. +c better segno +c coda +c duevolte +c Fix xtup bracket direction in 2-line staves?? (maybe leave as is) +c Sticky ornaments with shifts. +c Deal with Werner's vertical spacing thing associated with title. +c Multiple ties in midi +c Werner's missing c in MIDI due to start/stop ties on same note. +c Beams with single 64ths +c 128ths and/or dotted 64ths +c Close out MIDI with integral # of beats? +c Increase ast dimensions or redo logic. +c Does slur direction get set for user-defined single-note stem dir'ns? +c Transpose by sections. +c Optimization loop over sections only +c Command-line option to read nbarss in. Write out nbarss when optimizing. +c (or just read from .plg?) +c Beams over bar lines. +c 2-digit figures +c A real coule (slanted line between notes in a chord) +c Dotted slurs for grace notes. +c Undotted chord notes with dotted main note. +c Forced line break without line number +c Fix dot moving when 2nds in chord get flipped +c To do: increase length on notexq in dodyn +c 2.617 +c In g1etnote, change if-check for note to use index(...) instead +c of ichar(charq) since it was messing up gfortran optimizer +c After pmxa, search for and remove penultimate line / +c because it was screwing up linux-compiled versions +c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) +c 2.616 (111110) +c Allow hairpins to span multiple notes groups (gulps). +c 2.615+ (110810) +c Fix midi when some instruments are transposed, by subtracting +c iTransAmt(instno(iv)) from pitch values sent to via addmidi in +c make2bar.for (for main notes) and docrd (for chord notes) +c 2.615 (110725) +c Fig bug with size-setting (in topfile) when instrument has >1 staves +c 2.615 (110724) +c Make AS[0|-|s|t]... really set sizes +c 2.614 +c Mod notex.for to fix Terry's bug with raised dotted rests (caused +c by double-hboxing). +c 2.613 +c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. +c 2.612 +c Enhance AS to allow s or t for smallsize or tinysize +c 2.611 +c Error trap for "D" before any notes in a block. +c 2.610 +c Instrument-wise key changes and transposition (incomplete) +c 2.603 +c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors +c following reading in an include file. +c 101121 Added some error messages in g1etset.for setup data +c 2.602 +c Correct slur indexing in linebreakslurs. +c Account for comment lines in line count for error messages +c 2.601 +c Bug fix: allow 24 slurs with graces +c 2.60 Changes made make it really big +c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o +c major reprogramming, and 16 may also be a problem (icmm) +c nm=24 (voices) done +c 24 slurs done +c 24 simultaneous beams (Replace index 24 by 0, so get 0-23) +c bufq*131072 (gfortran only) +c getarg syntax (gfortran only) +c 2.523+ +c Fix voice numbering for normal dynamics and text dynamics +c 2.523 +c Version of bigpmx first posted to Hiroaki's web site. +c 2.522 +c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. +c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. +c 5/13/10 Fix log2 function +c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. +c 2.521+ +c 091025 Enable dotting 2nd part of linebreak slur or tie. +c To adjust barno height due to linebreak slur, use \bnrs instead of +c explicitly redefining \raisebarno (pmxb) +c 2.521 +c Bugfix +c 2.520 +c 090519 Enable ligfonts (special figured bass characters) +c 2.519 +c Fix another bug which kept \sk from being output so misaligned some notes. +c 2.518 +c Fix bugs: referencing fig data, char declaration for member of +c common/comfig/ +c 2.517 +c Allow figures in voice 1 + any one other. +c 2.516 +c Allow figures in voice #2 +c 2.515+ to do: Change manual and activate rule against clef change in voice #2. +c 2.515 +c 071222 Changes in getnote to allow auto forced beams to start anywhere. +c 071206 In make2bar, shift fermataup7 to left over centered pause. +c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line +c staff (it was screwing up vertical justification). +c n34 for tweaks to midi durations of quarter note septuplets. +c To do: In ref250.tex, the tables where 's,t,)' is explained, the line +c [+,- i] ... Vertical adjustment of the start of second segment +c should it be replaced by +c [s +,- i] ... Vertical adjustment of the start of second segment +c 2.514 +c Changes in make2bar to get horizontal spacing right when normal grace +c follows after grace +c Changes in dograce to get octaves right for any material entered inside +c \gaft, which shields transpose register changes from the outside world. +c 2.513 +c In make1bar, near end, for forced beams starting with a rest, copy hgt and +c slope tweaks to ALL notes after first, not just the second one, so if +c there's more than one rest at start the tweaks are still observed. +c In beamid and beamend, add stand-alone triply-flagged notes for xtups. +c 2.512 +c Near end of pmxb, fix error trap to allow redundant 'RD' +c Enable multiplicity down-up '][' within xtup. +c 2.511 +c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by +c adjusteskz as in bar 7 of barsant. +c 2.510a +c Test: remove restriction on tempo changes in MIDI macros +c Send to CM for beta testing. +c 2.509+ +c To do: Correct manual on AS. "-" is for smaller staves. +c 2.510 +c Forgot to declare litq, voltxtq as character in subroutine getgrace +c 2.509 +c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) +c 2.508 +c Allow graces in xtups. New subroutine getgrace. +c 2.507 +c To do: Raise/lower figures. +c To do: Add 24, 29 to list of musicsizes in manual +c New sub adjusteskz to account for ask's when computing lengths of +c brackets for unbeamed xtups, slopes and horizontal posn's of number +c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags +c Add look-left option for keyboard rests, "L" in rest command, set iornq(30) +c 2.506 +c Fix bug with AK, when simultaneous rests have same duration, use defaults. +c 2.505 +c Keyboard rests AK +c 2.504 +c Space after normal grace: option X[n] +c Fixed og when nv .ne. noinst, by using sepsymq instead of '&' +c (To do) length of xtup bracket when there is added non-collision space. +c Trap musicsize if .ne. 16,20,24,29. +c 2.503 +c Enable arpeggio left shift with ?-x +c To do: In manual, arpeggio over 2 staves. +c Allow musicsize of 24 and 29. Had to define meter font size explicitly, +c also change font size for text dynamics, but not much else so far. +c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn +c was called, causing error in printing replacement number. +c 2.502 +c Incorporate Dirk Laurie's patch to use { , } , for ties. +c Figure height adjustment: append +[n] +c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) +c 2.501 +c Readjust horizontal offset back to .8 in LineBreakTies +c Fix zero-subscript (iudorn) in putorn +c 2.50 +c Increase number of text-dynamics (dimension of txtdynq) per block +c from 12 to 41. +c Slur option n to override altered default curvature. +c Allow default ps slur curvature tweaks with Ap+/-c +c 2.416 +c Increase length of textdynq from 24 to 128 +c (Todo) Add comment in manual about blank lines at end. +c Configuration file: Define subroutine getpmxmod, check path in environment +c variable pmxmoddir, check existence, read lines into bufq after setup. +c Increase dimension on idynn in dodyn from 4 to 10 for max number +c of marks in a bar +c Increase allowable # of lines from 2000 to 4000. +c (To do) Replace definition of \liftpausc per Olivier. +c (To do) Fix extraneous error message if RD is placed at very end. +c 2.415 +c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt +c instead of redefining \xnum. Change font used to \smallfont (as for +c normal xtups, +c Allow slur to start on rest. +c 2.414 +c Correct bug in crdacc when adding accidental to boundary causes number of +c segments to decrease +c Special rule for 3-accidental chords: If no 2nds, place them in order +c top, bottom, middle. +c 2.413 +c Correct bugs in chordal accidentals, related to left-shifted noteheads +c (a) Special problems with downstem when main note needs shifting +c (b) Assign 0 rank to boundary segs due to left-shifted noteheads +c 2.412 +c Change default horiz shift of start of seg 2 of linebreak slurs: +c -.7 for slurs, -1.2 for ties, +c Use height of start of seg 1 slur itself for end of 1 and start of 2. +c 2.411 +c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. +c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end +c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. +c With "Apl", curvature adjustments on starting slur command apply to seg 1, +c those on ending command to seg 2. +c 2.410 +c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine +c \xnum, \unbkt, \ovbkt. +c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is +c flag, mult(5-9) is tweak value+16 +c 2.409 +c Bugfix in docrd for MIDI: Use original pitch in case main/chord were +c switched due to 2nds. +c Remove "o" from error message for "A" command. +c New syntax: optional instrument number separator ":" in movement +c break command to precede a 2-digit instrument. +c Conditional output formats for \setname at movement break to allow +c instrument numbers >9. +c Bugfix in coding to raise barno due to slur over line break (pmxb) +c Move date/version data statement in pmxab to a better place. +c 2.408 +c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). +c Bug fix in \liftPAusep in notex.for and in pmx.tex +c Character variables for version and date +c For up-stem single graces slurred to down-stem, shift slur start left by +c 0.8 so slur doesn't get too short. +c Initialize and slide mult, same as other full-program variables in /all/. +c 2.407 +c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, +c 2.406 +c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing +c equalization). +c Put dimensions of double sharps and flats in crdacc (for chords). +c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' +c Use only first 4 bits of mult for multiplicity+8, so rest can be used +c for other stuff. +c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. +c 2.405: Not published but saved for safety. +c Option Aph to write \special{header=psslurs.pro} top of each page, so +c dviselec will work OK. +c 2.404 +c Allow slur to end on rest, but not start on a rest. Efaults height +c of ending is default height of start (before any automatic or user- +c defined djustments). User may adjust height as normal from default. +c 2.403 +c Bugfix: turn off repeated beaming patterns.at end of non-last voice. +c 2.402 +c Automatic repeated forced beams. Start with "[:" End with next explicit +c forced beam or end of input block. +c Increase # of forced beams per line of music per input block from 20 to 40 +c 2.401 +c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. +c Makes 1st part normal shape, and starts 2nd part a little further left. +c Enable arpeggios in xtuplets. Had to make time itar(narp) a real. +c 2.40 +c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. +c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse +c sign for down-slurs. +c 2.359 +c Add error exit subroutine stop1 to make exit status g77-compatible.. +c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote +c Fermata on vertically shifted rest: special trap in putorn() to set height. +c Correct multiple grace note spacing for small staves (in dograce, +c define wheadpt1 depending on staff size) +c 2.358 +c Allow curvature corrections at start of postscript slur, in dopsslur() +c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust +c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] +c Make t[ID] act like s[ID]t, most mods in spsslur(). +c Add spsslur() to read in data for ps slurs, call from getnote. +c In beamstrt, save args for SetupB in common comipb to save them for +c 2nd call when xtup starts with rest +c Add spacing for ornament ")" as if it were accidental, in make2bar(). +c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() +c Horiz. shift start of ps grace slur, 2 places in dograce(). +c Horiz shift end of grace slur in endslur() +c Make st slurs into postscript ties. Separate subroutine dopsslur(), +c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) +c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. +c 2.357a +c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote +c 2.357 +c Increase dimension for # of lit TeX strings from 52 to 83. +c Allow blank rest in middle of xtuplet. Only mods in g*etnote(). +c 2.356 +c Increased some dimensions from 30 to 40 to allow up to 40 pages. +c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). +c Fix parsing of "f,h,H,HH" in sslur. +c Fix bug with cdot, note-level for slur termination (in getnote) +c 2.355 +c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], +c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues +c Make midi recognize ps ties in doslur. +c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote +c to get octave right. +c 2.354 +c With postscript slurs, make t-slurs real ties by inserting replacement +c macros \tieforisu, etc, defined in pmx.tex +c Check for open cresc or decresc at end of input block, using list[de]cresc +c Hairpin syntax conditional on postscript slurs. Backup to fill in start +c level, using new backfill(...). Separate height tweaks for +c start and finish. +c 2.353 +c K-0+n to transpose by half step (rather than just change key) +c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of +c \mbrest's +c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end +c of input block before movement break, and at start of block after +c movement break, using \newmovement rather than \setzalaligne, since +c former already redefines \stoppiece. In second case, set rptfg2='z'. +c Make clefq(nm) common between pmxb and getnote; change references in +c getnote at 'M' to array elements, setting all new clefs as you go. +c 2.352 +c Remove \parskip redefinition from pmx.tex; write it into TeX file when +c "Ae" is invoked. +c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine +c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', +c translate them thru mapping to (1,4,5,6) as \midslur params, then let +c \psforts translate them back to ps slur macors. +c 2.351 +c Number slurs from 0 up instead of 11 down, anticipating postscript slurs. +c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. +c Increase length of basenameq to 44 characters everywhere. +c Increase dimension of mcpitch (midi-chord-pitch) to 20. +c Set default systems per page to 1 if nv>7 +c In pmxb, move place where isystpg is reset to 0, so that \eject gets +c written when there is just one system per page. +c 2.35 +c Cautionary accidentals with 'c' anywhere in note symbol. +c NEW pmx.tex with \resetsize to set size to normal or small depending on +c current \internote. Used with new coding in dograce() to get right +c new size in case user has \setsize'ed some lines to \smallvalue. For +c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. +c Affects pmx.tex. +c Continuation figure with fractional length. May now mix with other figures. +c If another figure follow Cont-fig, separate with colon. +c 2.342 +c Bugfix in getnote to recognize relative octave shift in grace at start of +c input block. +c In make2bar, initialize islhgt=0 earlier than before (possible solution +c to Suse g77 compile problem that I could not reproduce).. +c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d +c 2.341 +c Syntax check: Forced page break page number must be > than previous. +c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. +c 2.34 +c New pmx.tex with redefined liftpausc +c Bug fix with dotted, non-beamed xtups. +c 2.332 +c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. +c Allow arbitrary pos. input to W in g1etnote and getnote. +c 2.331 +c Bug-fix in dodyn(..): typo on length of arg of txtdyn +c 2.33 +c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() +c 2.321 +c Rescale accidental shifts. Still use 7 bits but now map (0,127) +c onto (-1.,5.35) +c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups +c 2.32 (Noticed after posting) +c Prohibit "/" as figure. +c 2.32 (Posted) +c Tidied up accidentals in chords, do spacing. +c Still to do: +c check for "(" on chord notes in spacing algo +c small accids +c double accids +c autoshift slurs +c 2.310 +c Extra call to precrd ahead of spacing chk, and single-note crd/acc +c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. +c 2.309 +c Alternate algo for accid shifts in chords. +c 2.308 +c Auto horiz. notehead shifting added to precrd. +c 2.307 +c Auto shifting of multiple accidentals in chords. +c "Ao" in main chord note to keep accidentals in order. Set nacc(28). +c If there are any manual main or chord note shifts, then +c If any manual shift is preceded by "A" then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, +c End if +c End if +c 2.306 +c Initialize legacy note level to middle C in case user forgets to set +c octave. +c Shift xtup note? +c Shift in elemskips rather than noteheads? +c 2.305 +c Stop pmxb from multiple endvolta's at start of new page. +c 2.304 +c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on +c for multiple notes in the voice, "S:" last shortened note. +c 2.303 +c vshrink stuff all OK? Description is in pmxb. +c 2.302 +c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff +c hits 20. This still needs work. +c Add " /" to last line if last char is not % or /. +c 2.301 +c Check in beamn1 for single note before multiplicity down-up. +c allow '.PMX' as well as '.pmx' +c 2.299 +c Correct typo in pmxb involving PMXbarnotrue. +c Replacement printed number for xtup: Unsigned integer after 'n' after 'x' +c Minor upgrade parsing xtuplet options 'x...' +c Correct dimension of nxtinbm in make2bar. +c 2.298 +c Account for doubled xtup notes in subroutine getx (user-defined spaces), +c by adding ndoub as an argument.. +c 2.297 +c Created and solved compiler problem. Put drawbm(NM) in its own common. +c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar +c when \centerbar is used. +c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX +c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. +c 2.296 +c Correct printed numbers for forced beams with multiple xtups. For each beam +c make list in setupb by voice of eloff (h-offset) and mtupv (printed #) +c Increase lengths of jobname and infileq by 20 characters +c Enable whole notes and breves as 1st or last note of xtup in beamn1 and +c beamend, and wholes in beamid. +c 2.295 +c Midi balance Ib[n1]:[n2]:...[nn] +c Single-slope beam groups [...]-[...] +c Trap "i" unless after accidental (main notes, xtups, chord notes) +c 2.294 +c Unequal xtups with "D" to double a note in an xtup. +c As above, "F" will (a) increase multiplicity by 1 for marked note and next +c one and (b) add a dot to the first one. +c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on +c when "." is encountered, then correcting beam start time.(end of getnote) +c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... +c 2.293 +c Check for single notes spanning bar lines. +c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup +c must be set in make2bar since beamstrt is not called, fixing problem with +c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix +c problem when >2 staves. +c Add nodur to args of dodyn, so can check if stemless and avoid height tweak +c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak +c 2.292a +c Undo syntax check for Type 2 or 3 TeX string starting in column 1. +c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! +c 2.292 +c Allow comments in xtuplets +c Enable multiple octave jumps in grace notes. +c Allow dynamics in xtuplets. +c Fix bug in getdyn searching for end of text string (correct length of lineq +c to 128) +c Fix bug in dodyn, must ignore horiz. interaction tweak for +c user-text (idno = 0) +c Syntax check for Type 2 or 3 TeX string starting in column 1 +c (NOTE: later undone!) +c Syntax check for page number > npages at forced line break. +c 2.291 +c Fix error in AS command (accid spacing for small systems), making only +c one spec per staff, nv total. +c Stop using MIDI channel 10 +c 2.29 +c Fix error in console output format for # of bytes used in MIDI file. +c Fix bug in dograce so no space is added between grace and main note when +c there is a MIDI-only accidental. +c Fix bug so oes?+4 works. It was too ugly to explain. +c ...Different ways of storing accidental specs on input and output. +c No longer zap \writezbarno in special situations. +c Fix bug in dyntxt level on rest +c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. +c Activate with Ae. (Maybe later could input alternate values for +c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 +c in the page, and \endeq on 1st note of next-to-last line in page. +c 2.28 +c Flip direction of forced beam "[f..." +c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) +c Fix bug in sliding ip's for txtdyn's +c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) +c 2.27 +c Comment out lines in dodyn checking number of dynamic marks found. Voice +c order may not be monotonic if two lines on a staff. +c Literal dynamic: D"[text]" +c 2.26 +c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, +c increasing dimension of idynn to 4 to allow 4 symbols on same note. +c Increase voltxtq length from 10 to 20. +c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough +c accounting for ast's is done by defining effective headwidth +c whead1 in makebar2 to be 0.8*whead. +c 2.25 +c Fix logic bug with sepsym's when # of instruments changes. +c Slight increases in default offsets for hairpin starts after "p" +c 2.24 +c Hairpins D< or D> as toggle. +c Many automatic position tweaks for letter-group dynamics and hairpins. +c 2.23 +c Continued rhythmic shortcuts: space followed by "." or "," +c 2.22 +c In call to doslur, change tno(...) to tnote(...). This was only +c used when checking to slurs per stem directions, and should have been +c the note duration all along. +c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. +c Use "i" anywhere in note symbol. +c 2.21 +c Increase from 20 to 30 dimensions for movement breaks and midi sections. +c Fix out-of-order declarations per mutex comments +c Add "Bad error" and "Kluging" messages to log file. +c 2.197 +c add /comips/ to save tie-check midi variables +c For spacing of clef changes at start of input block, changed integer time +c lastnodur to prevtn, so it works with xtups. Possible incompatibility! +c 2.196 +c Fix Ickbug with time check in ncmid() +c Interchange \fermataup7 and \pausec to get proper alignment +c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. +c Add defn's of \hsp, \hspp to pmx.tex +c Fix pre-slurs on xtup chord notes. +c Fixed raised PAuse, define \liftPAuse +c Replace \zbreve\sk with \breve. +c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what +c about "o" and 1 as shorthand for 16???? Search for "Kluge" +c Added "vo" (voice) as MIDI instrument 55 +c Allow 3-digit page numbers (search for "toppageno") +c Fix bug caused by prior fix (cancelling accid after bar line was ignored). +c Fix double accids in chords +c 2.194 +c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if +c block. +c Add meter to MIDI file with every pause +c Purify FORTRAN? +c 2.193 +c Increased # of in-line TeX strings from 36 to 52. +c Fix entry of # of bytes in header of tempo/meter/key track to allow >255. +c 2.191 +c Event track: Tempos, meters, keys all together. Data in comevent +c 2.15 +c Pretty good midi capability. Still no attention to slurs on chord notes. +c 2.11 +c 11 Dec 99 c rm1 +c 11 Dec 99 "oes?", "oe?" +c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes +c 11 Dec 99 Error message for shifted, repeated ornaments. +c 2.10 (Version 2.1) +c Fix bug with lowdot and xtuplets +c 2.09 +c Fix bug with multiple ornament heights over beams, when one is . or _ +c Error message from pmxa if rest on last note of xtup. +c Enable 12 slurs. +c Reinstate multiple rests at start of xtup. +c 2.07 +c Combine consecutive type-1 TeX strings. +c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. +c Fixed breve chord notes in docrd +c Check irest(28) as well as vxtup when setting nodur for chord notes, since +c vxtup isn't set until 1st *main* note in xtup +c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. +c 2.06+ +c Make deterministic the beam slope calculation when there are an even # of +c slopes in list and middle two are equal magnitude but opposite sign. +c pmxa Trap for "o:" before 1st note in block +c Partial bug fix for 64th notes in xtuplets. +c Make ixrest a vector, since with new time scheme may not finish xtup in +c same notes block. +c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) +c 2.06 +c Account for changes in nv when computing \interstaff. Add a counter +c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever +c setting isysflb(iflb). Note nv can only change at a forced line break. +c Note also, iflb starts at 0! +c 2.05 +c Automatic start of new notes group with part 2 of staff-jump beam +c In make1bar, set irest bit 29 of lowest-voice note at same time, +c use as flag when making notes groups. +c For now, remove dummy blank line at end...it zaps terminal repeats. +c 2.02 +c Fixed slur-counting bug for multiple, slurred, aftergraces. +c 2.01 +c Increase to ask(1400) +c Increase max forced page breaks to 18 +c Define pausc for centered pause +c 2.0a +c Insert dummy blank line at very end to handle input files w/o terminal CR-LF +c pmx03r +c Option m[n] in S symbol to change musicsize (for parts) +c Double dotted rests now work. +c Write file name to log file +c Check existence of input file +c Allow 24-char jobname, may end with ".pmx" +c Comment out time stuff +c Replace 3-argument getarg with 2-argument + iargc +c Fix bug with negative noinst due to nint<=int replacement +c move lovation of iv in isdat1 to allow iv>7. +c Set nm=12 +c pmx03q +c replace int(x+.001) with nint(x) +c Write TeX file name to screen and to pml. +c Replace char(...) with chax(...) to sovle msdev bug. +c Bug fix: macro terminations when M is on a line by itself. +c Bug fix: don't accumulate space for XS in pmxa. +c Streamline Macros: use pointers to bufq instead of scratch files +c pmx03p +c Store input file in single character array bufq. +c lbuf(i)*2 is length of line i +c ipbuf is position just before next line to be read. +c pmx03 +c Optimize read/writes +c pmx02 +c Fix line count (for errors) when there are saved macros +c pmx01 +c In optimize mode, open/close macros (Watch out for residual zz files!) +c Command line input +c Option Ao to optimize, otherwise normal processing +c +ccccccc + parameter (nks=125,nm=24,mv=24576,maxblks=4000) + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /comevent/ miditime,lasttime + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + common /commus/ musize,whead20 + integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks) + real*4 poe0(nks),poe(nks) + logical isfirst,optimize + logical*4 fexist + character*44 jobname + character*47 infileq + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * idum,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + logical rest,firstline,newmeter + common /comdiag/ n69(0:nm),n34(0:nm) + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + common /truelinecount/ linewcom(20000) +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c +ccccccccccccccccccccccccc +c + data date /'28 Jan 12'/ + data version /'2617'/ +c +ccccccccccccccccccccccccc + data maxit,ncalls /200,0/ + data isfirst /.true./ +c itstart = mytime() + versionc = version +c +c Initialize midi parameters +c + gottempo = .false. + ismidi = .false. + debugmidi = .false. + relacc = .false. + mmacrec = .false. + nmidsec = 1 + mgap = 10 + miditime = 0 + lasttime = 0 + nmidcrd = 0 + nusebl = 0 + notmain = .false. + do 3 ivx = 1 , nm + twoline(ivx) = .false. + midinst(ivx) = 6 + midivel(ivx) = 127 + midibal(ivx) = 64 + miditran(ivx) = 0 +3 continue + do 12 icm = 0 , nm + imidi(icm) = 0 + restpend(icm) = .false. + trest(icm) = 0. + levson(icm) = 0 + levsoff(icm) = 0 + slmon(icm) = .false. + naccbl(icm) = 0 + n69(icm) = 0 + n34(icm) = 0 + msecstrt(icm,1) = 1 +12 continue +c +c End of midi parameter initialization +c + musize = 0 + optimize = .false. + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else +c call getarg(1,jobname,idum) ! May need to replace this w/ next line + call getarg(1,jobname) + end if +10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then + print*,'Jobname is too long. Try again.' + call stop1() + else if (ljob .eq. 0) then + print*,'No was jobname entered. Try again.' + call stop1() + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. +c call getarg(2,jobname,idum) ! May need to replace this w/ next line + call getarg(2,jobname) + numargs = 1 + go to 10 + else + print*,'Illegal option on command line' + call stop1() + end if + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + call stop1() + else + infileq = jobname(1:ljob)//'.PMX' + end if + end if +c +c Open a log file +c + open(15,file=jobname(1:ljob)//'.pml') + call printl('This is PMX, Version '//version//', '//date) + ljob4 = ljob + call printl('Opening '//infileq) + open(18,file=infileq) +c +c Copy input file into common buffer +c + ipbuf = 0 + linewcom(1) = 1 + do 8 ilbuf = 1 , maxblks + ncomments = 0 +14 read(18,'(a)',end=9)lnholdq + lbuf(ilbuf) = lenstr(lnholdq,128) + if (lbuf(ilbuf) .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lbuf(ilbuf) = 1 + lnholdq = ' ' + end if +c +c Now line has at least one non blank character. Check for comment +c As of Version 260, do not copy comments into bufq +c But need to count %'s for error messaging +c if (lnholdq(1:1).eq.'%') go to 14 + if (lnholdq(1:1).eq.'%') then + ncomments = ncomments+1 + go to 14 + end if +c +c When here, have counted all preceding comments and have a real line +c + if (ilbuf .gt. 1) then + linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments + else + linewcom(1) = 1+ncomments + end if + if (ipbuf+lbuf(ilbuf).gt.65536) then + print*,'Too many characters in file, stopping' + call stop1() + end if + bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq + ipbuf = ipbuf+lbuf(ilbuf) +8 continue + call printl('Too many lines in input file') + call stop1() +9 continue +c +c Insert dummy line to handle input files w/o CR-LF at end. +c + nlbuf = ilbuf-1 +c nlbuf = ilbuf +c bufq(ipbuf+1:ipbuf+3) = ' / ' +c lbuf(nlbuf) = 3 + close(18) + do 6 numit = 1 , maxit + if (optimize) call printl('Starting an iteration') +c +c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. +c Otherwise, nbars0 is the input +c When islast=.false., pmxb only returns poe's, otherwise does whole job +c + call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize) + if (.not.optimize) then + if (ismidi) then +c +c Set up channel numbers for midi. +c + numchan = 0 + do 11 iv = nv , 1 , -1 + if (twoline(iv)) then + midchan(iv,2) = numchan + numchan = numchan+1 + end if + midchan(iv,1) = numchan + numchan = numchan+1 +11 continue +c +c numchan will now be the number of channels, but max channel # is numchan-1 +c +c Set up velocities, balances, and midi-transpositions +c + do 13 iv = nv , 1 , -1 + if (twoline(iv)) then + midvelc(midchan(iv,2)) = midivel(iv) + midbc(midchan(iv,2)) = midibal(iv) + midtc(midchan(iv,2)) = miditran(iv) + end if + midvelc(midchan(iv,1)) = midivel(iv) + midbc(midchan(iv,1)) = midibal(iv) + midtc(midchan(iv,1)) = miditran(iv) +13 continue + end if +c +c TEMPORARY!!! +c + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + do 10000 ilb = 1 , nlbuf +c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), +c * bufq(ip1:ip1+lbuf(ilb)-1), +c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), +c * k=min(3,lbuf(ilb)),1,-1) + ip1 = ip1+lbuf(ilb) +10000 continue + iplast = ip1-1 +c +c Check to see if (1) last line is "/" and (2) next to last +c line is "/" +c +c print*,'iplast:',iplast +c print*,'Last line:' +c print*,bufq(iplast+1-lbuf(nlbuf):iplast) +c print*,'Last char of next to last line:' +c print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) + if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then + if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then + print*,'Removing last line of "/"' + write(15,*)'Removing last line of "/"' + nlbuf = nlbuf-1 + end if + end if +c + call pmxb(.true.,poe0,ncalls,optimize) + if (ismidi) then +c +c Write midi file +c + open(51,file=jobname(1:ljob)//'.mid') + if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm') + call printl(' ') + call printl('Writing '//jobname(1:ljob)//'.mid') + call writemidi(jobname,ljob) + end if + close(15) + stop + end if + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + call pmxb(.false.,poe0,ncalls,optimize) + call poestats(nsyst,poe0,poebar0,devnorm0) +c +c Save initial deviation and line breaks for later comparison +c + if (numit .eq. 1) then + devpmx = devnorm0 + do 20 isys = 1 , nsyst + nbari(isys) = nbars0(isys) +20 continue + end if + call sortpoe(nsyst,poe0,ipoe) + do 1 iupord = nsyst , 1 , -1 + isysu = ipoe(iupord) + print*,'isysu=',isysu + write(15,*)'isysu=',isysu +c +c Skip if system isysu has poe0 < avg or isysd has poe0 > avg +c + if (poe0(isysu).lt.poebar0) go to 1 + do 5 idnord = 1 , nsyst + isysd = ipoe(idnord) + if (isysu.eq.isysd .or. nbars0(isysd).eq.1 + * .or. poe0(isysd).gt.poebar0) go to 5 + do 2 isyst = 1 , nsyst + nbars(isyst) = nbars0(isyst) + if (isyst .eq. isysu) then + nbars(isyst) = nbars(isyst)+1 + else if (isyst .eq. isysd) then + nbars(isyst) = nbars(isyst)-1 + end if +2 continue + call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize) + call pmxb(.false.,poe,ncalls,optimize) + call poestats(nsyst,poe,poebar,devnorm) + if (devnorm .lt. devnorm0) then + devnorm0 = devnorm + poebar0 = poebar + do 4 isys = 1 , nsyst + nbars0(isys) = nbars(isys) + poe0(isys) = poe(isys) +4 continue + print*,'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(15,*)'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call sortpoe(nsyst,poe0,ipoe) + go to 6 + end if +5 continue +1 continue +c +c If we get here, must have gone thru all switches and found nothing better, +c so done! +c + go to 7 +6 continue +7 continue + print*,'Optimum located, numit:',numit,', ncalls:',ncalls + write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls + print*,'Final error:',devnorm0,', initial error:',devpmx + write(15,*)'Final error:',devnorm0,', initial error:',devpmx + print*,'Percentage improvement:',100.*(1-devnorm0/devpmx) + write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx) + call printl('Initial bars/system:') + write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + call printl('Final bars/system:') + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize) + call pmxb(.true.,poe0,ncalls,optimize) +c itend = mytime() +c print*,'Elapsed time in ms:',itend-itstart +c write(15,*)'Elapsed time in ms:',itend-itstart + close(15) + end + subroutine accsym(nacc,acsymq,lacc) + character*3 acsymq + iacc = iand(nacc,7) + if (iacc .eq. 1) then + acsymq = 'fl' + lacc = 2 + else if (iacc .eq. 2) then + acsymq = 'sh' + lacc = 2 + else if (iacc .eq. 3) then + acsymq = 'na' + lacc = 2 + else if (iacc .eq. 5) then + acsymq = 'dfl' + lacc = 3 + else if (iacc .eq. 6) then + acsymq = 'dsh' + lacc = 3 + else + print*,'bad accidental: ',iacc + end if + return + end + subroutine addask(taskn,waskn,elaskn, + * fixednew,scaldold,tglp1,isudsp) + parameter (nm=24) + logical isudsp + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comtol/ tol + if (isudsp) then +c +c Find which udsp we're dealing with +c + do 1 iudsp = 1 , nudsp + if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2 +1 continue + print*,'You should note BEEE here in addask!' + call stop1() +2 continue +c +c Fixednew and scaldold must not be changed, since udsp's are already included +c in fsyst from pmxa, and udsp don't involve scaled space.. +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c Must add user-defined space to what's there already. +c + wask(naskb) = wask(naskb)+udsp(iudsp) + else +c +c This place has no other space. +c + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = udsp(iudsp) + elask(naskb) = 0. + end if + else +c +c This is a normal space, no effect if smaller than existing space +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c We already put in some space at this time +c Check if new one needs more space than old one at same time +c + if (waskn .gt. wask(naskb)) then + naskb = naskb-1 + else + return + end if + end if + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = waskn + elask(naskb) = elaskn + fixednew = fixednew+waskn + scaldold = scaldold+elaskn + end if + return + end + subroutine addblank(noteq,lnoten) + character*8 noteq + character*1 tchar + tchar = noteq + noteq = ' '//tchar + lnoten = 2 + return + end + subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd) + parameter (nm=24) + integer nfb(nm) + common /comtol/ tol + real*4 t1fb(nm,20),t2fb(nm,20) + character*1 ulfbq(nm,20) + ifbadd = 1 + nfb(iv) = nfb(iv)+1 + do 1 ifb = nfb(iv)-1 , 1 , -1 + if (tnew .lt. t1fb(iv,ifb)-tol) then + t1fb(iv,ifb+1) = t1fb(iv,ifb) + t2fb(iv,ifb+1) = t2fb(iv,ifb) + ulfbq(iv,ifb+1) = ulfbq(iv,ifb) + else + ifbadd = ifb+1 + go to 2 + end if +1 continue +2 continue + t1fb(iv,ifbadd) = tnew + ulfbq(iv,ifbadd) = 'x' + return + end +c +c + subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) + parameter(nm=24,mv=24576) + integer*2 mmidi,itk(25) + integer*4 itiesav(5,100) + character*1 notenumq + logical endrest,eximacc,it1found + logical rest + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Following variables are local but must be saved. I hope they are. +c (3/18/00) With g77 they are not, so add a common block here. +c +c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) + integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15) + common /comips/ ipslon,lusebl,jusebl +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c +c Cancel out barline accidentals if there's a rest. +c + if (rest) naccbl(icm) = 0 +c +c Special path to insert dummy rest at end of a section +c + if (endrest) go to 20 +c + do 7 ion = 0 , nmidcrd +c +c check if this is only to get pitch of a chord note +c + if (notmain) go to 6 +c +c check for rest +c + if (rest) then +c +c Will not put in a note, but must update timing +c + if (.not.restpend(icm)) then +c +c First rest in sequence, save the time +c + restpend(icm) = .true. + trest(icm) = time + else + trest(icm) = trest(icm)+time + end if +c +c Note: code checkers don't like the above due to calling addmidi(trest(icm)) +c but this only happens if rest at end of section (endrest=.true.) (called +c from getmidi(), in which case these above lines are bypassed. +c + call chkimidi(icm) + return + end if +c +c time tics +c + if (imidi(icm).gt.0 .and. ion.eq.0) then + idur = mgap + else + idur = 0 + end if + if (restpend(icm)) then + restpend(icm) = .false. + idur = idur+nint(15*trest(icm)) + end if +c +c time to start of note +c + idurvar = isetvarlen(idur,nby2on) + if (nby2on .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + do 2 i = 1 , nby2on +c +c imidi points to cell before highest (leftmost) byte. Start with lowest byte +c at far right, fill in backwards +c + mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256) + if (nby2on .gt. 1) idurvar = idurvar/256 +2 continue + imidi(icm) = imidi(icm)+nby2on-1 +c +c Note-on signal +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 9*16+icm + mmidi(icm,imidi(icm)) = 9*16+icmm(icm) +c +c Entry point for chord note pitch determination +c +6 continue +c +c Get midi pitch. On chord iteration, only do this first time (main note), +c since pitch was already computed for nonmain chord notes. +c + if (ion .eq. 0) then + ipsav = nolev*12./7+11 + ipsav0 = ipsav + if (isig .ne. 0) then +c +c Adjust for signature +c + notenumq = char(48+mod(nolev,7)) + if (isig.ge.index('4152630',notenumq)) then + ipsav = ipsav+1 + else if (-isig.ge.index('0362514',notenumq)) then + ipsav = ipsav-1 + end if + end if +c +c Deal with accidentals. +c +c iacc 0 1 2 3 4 5 6 7 +c effect X fl sh na X dfl dsh X +c iashft X -1 1 0 X -2 2 X +c + jacc = 0 + eximacc = .false. + if (iacc .gt. 0) then +c +c Adjust key-sig-adjusted pitch for explicit accidental (and exit) +c + jacc = iashft(iacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav +c +c (Above) Shift applies to diatonic pitch but will be added to adjusted one +c + else if (naccim(icm) .gt. 0) then +c +c Possible implicit accidental from earlier in the bar +c Check for prior accid in this bar at this note level +c + do 3 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + jacc = jaccim(icm,kacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 4 + end if +3 continue +4 continue + end if +c +c Must split off the following if block from those above because chord +c notes can cause naccim>0, forcing us to miss other chord note's +c accross-bar-line accidental +c + if (naccbl(icm).gt.0 .and. .not.eximacc) then +c +c Possible carryover accid from prior bar (or prior same-pitch note). +c + do 21 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev) then + jacc = jaccbl(icm,kacc) +c +c Since we are *using* the bar-line accid, must flag it to be saved for next. +c + nusebl = nusebl+1 + jusebl(nusebl) = jacc + lusebl(nusebl) = nolev + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 22 + end if +21 continue +22 continue + end if + ipsav = ipsav+jacc +c +c Midi transpositions +c + ipsav = ipsav+midtc(icm) + end if + if (notmain) then + mcpitch(nmidcrd) = ipsav +c +c Save pitch for tie checks +c + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + imidi(icm) = imidi(icm)+1 + if (ion.eq.0) then + mmidi(icm,imidi(icm)) = ipsav + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ion) + end if + end if + if (ion .eq. 0) then +c +c Only record accids for non-chords, main chord note during chord iteration +c and chordnotes on first call but not during iteration +c + if (iacc.gt.0) then +c +c Set marker for accidental for possible continuations later this bar +c but first check and clear earlier ones on same note. +c + do 23 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + do 24 macc = kacc , naccim(icm)-1 + laccim(icm,macc) = laccim(icm,macc+1) + jaccim(icm,macc) = jaccim(icm,macc+1) +24 continue + go to 25 + end if +23 continue + go to 26 +25 continue + naccim(icm) = naccim(icm)-1 +26 continue +c +c Flag new accidental +c + naccim(icm) = naccim(icm)+1 + laccim(icm,naccim(icm)) = nolev + jaccim(icm,naccim(icm)) = iashft(iacc) + end if +c +c Bail if this is a chord note on the first call (from docrd) +c + if (notmain) then + call chkimidi(icm) + return + end if + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 127 + mmidi(icm,imidi(icm)) = midvelc(icm) + call chkimidi(icm) +7 continue +c +c For tie checks +c + if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm) +c +c Entry point for special rests at section ends (endrest=T) +c +20 continue +c +c Now insert all the ends +c + do 8 ioff = 0 , nmidcrd + if (ioff .eq. 0) then +c +c time to end +c + idur1 = nint(15*time) + if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then + idur = idur1-mgap + else + idur = idur1 + end if +c +c Deal with roundoff problems with 7-tuplets on half or quarters +c + if (idur1 .eq. 69) then + n69(icm) = n69(icm)+1 +c if (mod(n69(icm)+6,7) .gt. 3) idur = 58 + if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1 + else if (idur1 .eq. 34) then + n34(icm) = n34(icm)+1 + if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1 + end if + idurvar = isetvarlen(idur,nby2off) + if (nby2off .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + call chkimidi(icm) + do 1 i = 1 , nby2off + mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256) + if (nby2off .gt. 1) idurvar = idurvar/256 +1 continue + imidi(icm) = imidi(icm)+nby2off-1 + else +c +c Inserting end of chord note, delta time is 0 +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + end if +c +c Note off +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 8*16+icm + mmidi(icm,imidi(icm)) = 8*16+icmm(icm) +c +c Pitch +c + imidi(icm) = imidi(icm)+1 + if (ioff .eq. 0) then + mmidi(icm,imidi(icm)) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ioff) + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + call chkimidi(icm) + if (endrest) then + return + end if +c +c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time +c +8 continue + naccbl(icm) = nusebl + if (nusebl .gt. 0) then +c +c Fix tables of "bar-line" accids that are saved due to consecutive notes. +c + do 30 kacc = 1 , nusebl + laccbl(icm,kacc) = lusebl(kacc) + jaccbl(icm,kacc) = jusebl(kacc) +30 continue + nusebl = 0 + end if +c +c Begin tie checks +c + if (slmon(icm)) then +c +c Prior note had a slur start +c + if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then +c +c We have a tie! (Assumed there would be no accidental on tie-ending note) +c Make a list of times of all events back to the one starting at imidso+1, +c which is at or before where the tie started. Ident tie start and stop by +c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) +c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial +c time. + nsav4tie = 0 + imidt = imidso(icm) +10 nsav4tie = nsav4tie+1 + itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes) + imidt = imidt+nbytes + do 11 j = 1 , 3 + itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j) +11 continue + imidt = imidt+3 + if (nsav4tie .eq. 1) then + itiesav(5,1) = itiesav(1,1) + else + itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+ + * itiesav(5,nsav4tie-1) + end if + if (imidt .ne. imidi(icm)) go to 10 +c +c Find which two pitches agree with saved slur pitch. +c + it1found = .false. + do 12 it2 = 1 , nsav4tie + if (itiesav(3,it2) .eq. ipslon(icm)) then + if (it1found) go to 13 + it1 = it2 + it1found = .true. + end if +12 continue + call printl( + * 'Program error, tied notes, send source to Dr. Don') + it1 = nsav4tie+1 + it2 = nsav4tie+1 +13 continue +c +c List the positions we want to keep +c + jsav = 0 + do 14 isav = 1 , nsav4tie + if (isav.eq.it1 .or. isav.eq.it2) go to 14 + jsav = jsav+1 + itk(jsav) = isav +14 continue + nsav4tie = nsav4tie-2 +c +c Now dump events it1 & it2, recompute times, restack mmidi. +c + imidi(icm) = imidso(icm) + do 15 isav = 1 ,nsav4tie + if (isav .eq. 1) then + idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes) + else + idurvar = isetvarlen(itiesav(5,itk(isav))- + * itiesav(5,itk(isav-1)),nbytes) + end if + imidi(icm) = imidi(icm)+1 + do 16 i = 1 , nbytes + mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256) + if (nbytes .gt. 1) idurvar = idurvar/256 +16 continue + imidi(icm) = imidi(icm)+nbytes-1 + do 17 i = 2 , 4 + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = itiesav(i,itk(isav)) +17 continue +15 continue + end if + slmon(icm) = .false. + levsoff(icm) = 0 + if (.not.dbltie) levson(icm) = 0 + end if + if (levson(icm).gt.0) slmon(icm) = .true. + if (nmidcrd .gt. 0) nmidcrd = 0 + call chkimidi(icm) + return + end + subroutine addstr(notexq,lnote,soutq,lsout) + common /comlast/ islast,usevshrink + logical islast,usevshrink + character*(*) notexq + character*80 soutq + if (lsout+lnote .gt. 72) then + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + end if + if (lsout .gt. 0) then + soutq = soutq(1:lsout)//notexq(1:lnote) + else + soutq = notexq(1:lnote) + end if + lsout = lsout+lnote + return + end + subroutine adjusteskz(ib,squez,istart,istop,poenom) +c +c For block ib, this adds accidental spaces to eskz, for use in getting +c length of xtup bracket and slopes of brackets and beams. +c + parameter (nm=24) + common /comas1/ naskb,task(40),wask(40),elask(40) + real*4 squez(80) + integer*4 istart(80),istop(80) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comeskz2/ eskz2(nm,200) + common /comtol/ tol + common /comntot/ ntot + inmin = istart(ib)+1 + do 10 iaskb = 1 , naskb + if (task(iaskb) .lt. to(istart(ib))-tol) go to 10 + eskadd = wask(iaskb)/poenom-elask(iaskb) + do 11 in = inmin , ntot + if (to(in) .gt. task(iaskb)-tol) then + eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd + if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1 + else + inmin = inmin+1 + end if +11 continue +10 continue + return + end + subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + logical figbass,ispoi,topmods,istype0,done,isbbm + common /comhsp/ hpttot(176) + common /compoi/ ispoi + common /combbm/ isbbm + common /comas3/ ask(2500),iask,topmods + character*40 pathnameq + character*44 basenameq + character*1 sq,chax + character*129 outq + sq = chax(92) + open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex') +c +c Transfer first 5 lines of main internal TeX file +c + do 11 il = 1 , 5 + call moveln(11,12,done) +11 continue + if (istype0) then +c +c Transfer literal TeX stuff from special scratch file +c + rewind(17) +10 call moveln(17,12,done) + if (.not.done) go to 10 + close(17) + end if +c +c Transfer next 2 lines from main scratch file +c + do 3 il = 1 , 2 + call moveln(11,12,done) +3 continue + if (ispoi) write(12,'(a)')sq//'input musixpoi' + if (isbbm) write(12,'(a)')sq//'input musixbbm' + if (figbass) then +c +c Transfer .fig data from scratch (unit 14) into external .tex (unit 12) +c +4 call moveln(14,12,done) + if (.not.done) go to 4 + close(14) + end if + iask = 0 + ihs = 0 +1 read(11,'(a129)',end=999)outq +c +c Hardspaces. +c + if (outq(1:5) .eq. sq//'xard') then + ihs = ihs+1 + outq(2:2) = 'h' + write(outq(12:15),'(f4.1)')hpttot(ihs) + lenout = 19 + go to 9 + end if +c +c This part hard-wires ask's into new .tex file as ast's +c +2 indxask = index(outq,sq//'ask') + if (indxask .ne. 0) then + iask = iask+1 + call putast(ask(iask),indxask,outq) + go to 2 + end if + lenout = llen(outq,129) +9 continue + write(12,'(a)')outq(1:lenout) +c +c If this is the line with "readmod", check for topmods. +c + if (topmods .and. outq(2:8).eq.'readmod') then + topmods = .false. + rewind(16) + do 7 il = 1 , 1000 + read(16,'(a129)',end=8)outq + lenout = llen(outq,129) +c +c We inserted the '%' in subroutine littex, to guarantee including blank. +c + write(12,'(a)')outq(1:lenout) +7 continue +8 continue + close(16) + end if + go to 1 +999 close(11) + close(12) + return + end + subroutine backfill(iunit,oldq,lenold,newq,lennew) +c +c In iunit, looks backward for oldq, overwrites newq +c Safest if both are same length! +c + character*128 lineq(200),nowq + character*(*) oldq,newq + linesback = 0 +1 continue + backspace(iunit) + read(iunit,'(a)')nowq + ndx = index(nowq,oldq(1:lenold)) +c +c Save the line just read +c + linesback = linesback+1 + lineq(linesback) = nowq + if (ndx .eq. 0) then + backspace(iunit) + go to 1 + end if +c +c If here, it's replacement time. +c + lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew) + * //nowq(ndx+lenold:128) + backspace(iunit) + do 2 line = linesback , 1 , -1 + write(iunit,'(a128)')lineq(line) +2 continue + return + end + subroutine beamend(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + character*4 tempq + character*8 noteq + character*79 notexq + ip = ipo(jn) + multip = iand(mult(ivx,ip),15)-8 + if (ixrest(ivx) .eq. 4) then +c +c This is the LAST note in the xtup (i.e., all rests before). Make single. +c + nodur(ivx,ip) = 2**(4-multip) + call notex(notexq,lnote) + ixrest(ivx) = 0 + return + end if + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip-1),27)) + * nodur(ivx,ip)=nodur(ivx,ip)/2 + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = lnoten+3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+1 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+2 + else if (multip .eq. -2) then + notexq = sq//'wh'//noteq + else if (multip .eq. -3) then + notexq = sq//'breve'//noteq + lnote = lnote+3 + else + print* + print*,'(Error in beamend, send source to Dr. Don)' + call stop1() + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + end if + end if + end if + return + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + lnote = 0 +c +c New way, with flipend, which was computed in beamstrt. +c + if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) + * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then +c +c This is not a one-noter from beam-jump. Check if multiplicity has increased +c + if (btest(irest(ivx,ip-1),0)) then +c +c Prior note is a rest, check one before that +c + mp = iand(mult(ivx,ip-2),15)-8 + else + mp = iand(mult(ivx,ip-1),15)-8 + end if + if (multip .gt. mp) then +c +c Assume 1-3, 2-3, or 1-2 +c + do 2 imp = multip , mp+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +2 continue + else if (btest(nacc(ivx,ip-1),27)) then +c +c 2nd member of dotted xtup +c + call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if + end if +c +c Beam termination and direction analysis +c + if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then +c +c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number +c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the +c voice of the 2nd part of jumped beam. (May need special treatment for +c multi-segment jump-beams +c + isbjmp = .true. + ivbj1 = ivx + ivbj2 = 0 + end if + if (.not.btest(irest(ivx,ip),23)) then +c +c This is either a normal beamend or end of a sequence of jump-beam segments, +c so some sort of termination is required +c + ulqq = ulq(ivx,ibmcnt(ivx)) + if (.not.isbjmp .or. ivx.ne.ivbj2) then +c +c Normal termination +c + call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) + else +c +c Terminate a sequence of jump-beam segments. +c + ulqq = chax(225-ichar(ulqq)) + call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote) + end if + end if +c +c And now the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (.not.vxtup(ivx)) then + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (.not.btest(iornq(ivx,ip),13)) then + notexq = notexq(1:lnote)//'p' + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if +c +c 5/25/08 Allow >12 +c 5/9/10 Up to 24; replace 24 with 0 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + if (isbjmp .and. ivx.eq.ivbj2 + * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false. + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamid(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm + character*79 notexq + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + character*8 noteq + character*4 tempq + lnote = 0 + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.btest(irest(ivx,ip),0)) then + multip = iand(mult(ivx,ip),15)-8 +c if (btest(islur(ivx,ip-1),3)) multip = multip+1 +c +c (Above test OK since must have ip>1). Double dotted note preceding +c +c Move the following, because can't ask for note until after checking for +c embedded xtup with number, due to ordering/octave feature. +c +c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) + end if + if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true. + if (vxtup(ivx)) then +c +c In an xtup +c + if (btest(irest(ivx,ip),0)) then +c +c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK +c + nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8)) + call notex(notexq,lnote) +c +c Re-zero so next note does not get confused +c + nodur(ivx,ip) = 0 + return + end if +c if (multip.le.0) then +c if (multip.le.0 .or. +c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip),19) .or. + * btest(nacc(ivx,ip),27)) then + nodur(ivx,ip)=3*nodur(ivx,ip)/2 + else if (btest(nacc(ivx,ip-1),27)) then + nodur(ivx,ip)=nodur(ivx,ip)/2 + end if + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else +c +c Use ulq for stem direction +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + end if + if (btest(nacc(ivx,ip),27)) then +c +c This note is regular dotted non-beamed xtup +c + notexq = notexq(1:3)//'p' + lnote = 4 + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + end if + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + else if (nodur(ivx,ip).eq.0) then +c +c In the beamed xtup but not the last note +c + if (nodur(ivx,ip-1).gt.0) then +c +c Embedded Xtup, mult>0, starts here. Put in number if needed +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + iud = 1 + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1 +c +c Get ip#, notelevel of middle note (or gap) in xtup +c + ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ip),14)) then + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Place number if needed +c + if (.not.btest(islur(ivx,ip),31)) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multip,iud,wheadpt,poenom, + * nolev1(ivx),islope(ivx),slfac, + * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum, + * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.) + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + else +c +c Intermediate note of xtup +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else +c +c Last note of xtup (but not last note of beam!) +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else if (btest(irest(ivx,ip),0)) then + call notex(notexq,lnote) + return + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if +c +c Check if multiplicity changes in a way requiring action +c + ipleft = ip-1 + if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1 + if (.not.btest(islur(ivx,ipleft),20)) then + multl = iand(15,mult(ivx,ipleft))-8 + else + multl = 1 + end if + mub = multip - multl + ipright = ip+1 + if (btest(irest(ivx,ipright),0)) ipright = ipright+1 + if (.not.btest(islur(ivx,ip),20)) then + multr = iand(15,mult(ivx,ipright))-8 + else + multr = 1 + end if + mua = multr-multip + if (mub.gt.0 .or. mua .lt. 0) then +c +c Multiplicity has increased from left or will decrease to right. Need action. +c + if (isbjmp .and. ivx.eq.ivbj2) then + ivb = ivbj1 + ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + else + ivb = ivx + ulqq = ulq(ivx,ibmcnt(ivx)) + end if + if (mua .ge. 0) then + call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote) + else if (multl .ge. multr) then + do 1 im = multip , 1+multr, -1 + call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) +1 continue + else + do 2 im = 1+multr, multip + call ntrbbb(im,'r',ulqq,ivb,notexq,lnote) +2 continue + call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote) + end if + else if (ip .gt. 1) then +c +c Check for 2nd member of dotted xtup +c + if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if +c +c Now put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (isdotted(nodur,ivx,ip)) then +c +c rule out ')' +c + if (.not.btest(iornq(ivx,ip),13)) then + if (.not.btest(islur(ivx,ip),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + else if (btest(nacc(ivx,ip),19) + * .or. btest(nacc(ivx,ip),27)) then +c +c Special dotted notation for 2:1 xtup, or normal dot in xtup +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c 5/25/08 Allow >12 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamn1(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /comoct/ noctup + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*8 noteq + character*79 notexq + ip1 = ipo(jn) + multip = iand(15,mult(ivx,ip1))-8 +c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then + if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then + lnote = 0 +c +c The rest was already written in beamstrt, so just get out of here +c + return + end if + nole = nolev(ivx,ipo(jn)) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ipo(jn)),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ipo(jn)),31)) then + nole = nole + 1 + end if + if (vxtup(ivx) .and. .not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip1),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip1) + nodur(ivx,ip1) = 2**(4-multip) + if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2 + call notex(notexq,lnote) + nodur(ivx,ip1) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + else if (multip .eq. -3) then + notexq = sq//'breve' + lnote = 6 + else + print* + print*,'(Error in beamn1, send source to Dr. Don)' + call stop1() + end if + if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then + notexq = notexq(1:3)//'p' + lnote = 4 + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + end if +c +c Check if mult. decreases from 1st note to 2nd +c + if (ibm2(ivx,ibmcnt(ivx)).gt.ip1 + * .or. btest(islur(ivx,ip1),20)) then +c +c More than one note or single-note before a multiplicity-down-up "][" +c + if (btest(islur(ivx,ip1),20)) then + multr = 1 + else if (.not.btest(irest(ivx,ip1+1),0)) then + multr = iand(15,mult(ivx,ip1+1))-8 + else + multr = iand(15,mult(ivx,ip1+2))-8 + end if + lnote = 0 + if (multr .lt. multip) then + do 1 im = multip , multr+1 , -1 + call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +1 continue + end if + end if +c +c Put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 +c +c Check for dot +c + isdotm = .false. + if (.not.vxtup(ivx)) then + nd = nodur(ivx,ipo(jn)) + if (nd.ne.0) then + if (2**log2(nd).ne.nd) then + if (.not.btest(iornq(ivx,ip1),13)) then + if (.not.btest(islur(ivx,ip1),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if + else if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) then +c +c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c Do the number; 0 if 12 +c +c 5/25/08 allow >12 +c + if (.not.btest(irest(ivx,ip1),24)) then +c call istring(mod(ivx,12),noteq,len) + call istring(mod(ivx,24),noteq,len) + else +c call istring(mod(ivbj1,12),noteq,len) + call istring(mod(ivbj1,24),noteq,len) + end if + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + character*79 inameq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm + common /comeskz2/ eskz2(nm,200) + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c The following is just to save the outputs from SetupB for the case of +c xtups starting with a rest, where beamstrt is called twice. +c + common /comipb/ nnb,sumx,sumy,ipb(24),smed + character*8 noteq + character*79 notexq,tempq + integer nornb(nm),ihornb(nm,24) + real*4 space(80),squez(80) + logical novshrinktop,cstuplet,usexnumt + common /comnvst/ novshrinktop,cstuplet + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ibc = ibmcnt(ivx) + ipb1 = ibm1(ivx,ibc) + multb = iand(15,mult(ivx,ipb1))-8 + ip = ipo(jn) +c +c Compute slopes and note offsets from start of beam. Inside SetupB, for each +c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. +c + if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) + * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) + if (btest(nacc(ivx,ip),21)) then +c +c This is start of later segment of single-slope beam group so use slope and +c height from prior beam. Slope is already OK. +c + issb(ivx) = issb(ivx)+1 + nolev1(ivx) = lev1ssb(ivx,issb(ivx)) + end if + lnote = 0 + drawbm(ivx) = .true. + if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then + vxtup(ivx) = .true. + nxtinbm(ivx) = nxtinbm(ivx)+1 +c +c irest(28)=>Xtup starts on this note. Set up for xtuplet. +c Number goes on notehead side at middle note (or gap) of xtup, unless that +c puts it in staff, then it flops to stem (or beam) side. +c __ __ +c | | | O | | +c O | | O +c |___| O |__| | +c +c iud -1 -1 1 1 ...stem direction +c iflop 0 1 -1 0 ...direction of flop +c iup -1 1 -1 1 ...direction of number and bracket +c + iud = 1 + if (ulq(ivx,ibc) .eq. 'u') iud = -1 +c +c Get ip#, note level of middle note (or gap) in xtup +c + ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ipb1),14)) then +c +c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) +c + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Determine if a beam is to be drawn +c + do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc) + if (iand(15,mult(ivx,ipp))-8 .le. 0) then + drawbm(ivx) = .false. + go to 6 + end if +5 continue + drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18) +6 continue +c +c Are we using tuplet.tex? +c + usexnumt = cstuplet .and. .not.drawbm(ivx) +c +c Place xtup number if needed +c + if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multb,iud,wheadpt, + * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1), + * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)), + * iup,irest(ivx,ipb1),usexnumt) + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam +c + if (.not.btest(islur(ivx,ipb1),31)) then +c +c Number printing has not been suppressed, so put in the bracket. +c scale = stretch factor for bracket if there are asx's +c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) +c + xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1) + * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib)) + if (iup .eq. 1) then + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'ovbkt' + else + notexq = sq//'ovbkt' + end if + else + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'unbkt' + else +c +c Introduced 12/5/98, req'd due to possible presence of in-line TeX +c + notexq = sq//'unbkt' + end if + end if + lnote = lnote+6 + if (iline.eq.1) then + smed = smed/(1.-fracindent) + end if + xslope = 1.8*smed*slfac + islope(ivx) = nint(xslope) + nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1)) + if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1 + if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4 + levbracket = nolev1(ivx) + if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1 + call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+lnoten+1 + if (xnsk .lt. 0.995) then + write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk + lnote = lnote+4 + else if (xnsk .lt. 9.995) then + write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk + lnote = lnote+5 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + if (btest(mult(ivx,ipb1),4)) then +c +c Tweak slope of bracket +c + islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16 + end if + if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (islope(ivx) .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx) + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx) + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx) + lnote = lnote+1 + end if +c +c Done with bracket +c + end if + if (ixrest(ivx) .eq. 1) then +c +c Put in the rest. Possible problem: Rest is a spacing char, but between +c beamstrt and beamn1 some non-spacing chars. are inserted. +c + 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 +c +c No need to come back through this subroutine (as would if rest starts bar +c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. +c + ixrest(ivx) = 0 + end if + return + end if +c +c End if block for non-beamed xtup start...note we returned +c + if (ixrest(ivx) .eq. 1) then +c +c Insert rest at start of beamed xtup. See above note for possible problem. +c + nodur(ivx,ipb1) = 2**(4-multb) + call notex(tempq,ltemp) + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//tempq(1:ltemp) + else + notexq = tempq(1:ltemp) + end if + lnote = lnote+ltemp +c +c Re-zero just in case! +c + nodur(ivx,ipb1) = 0 + ibm1(ivx,ibc) = ibm1(ivx,ibc)+1 +c +c See if next note is a non-rest +c + if (.not.btest(irest(ivx,ipb1+1),0)) then + ixrest(ivx) = 2 + else +c +c Suppress reprinting xtup number next time through beamstrt +c + islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31) +c +c Set new xtup start flag +c + irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28) + end if + return + end if + end if +c +c Just ended if block for xtups +c + if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then +c +c Move actual note writing to beamend +c + ixrest(ivx) = 4 + return + end if + if (issb(ivx) .eq. 0) then +c +c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed +c + iadj = igetbits(ipl(ivx,ipb1),6,11)-30 + if (iadj .ne. -30) then + nolev1(ivx) = nolev1(ivx)+iadj + do 2 isssb = 1 , nssb(ivx) + lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj +2 continue + end if + iadj = igetbits(ipl(ivx,ipb1),6,17)-30 + if (iadj .ne. -30) then + islope(ivx) = islope(ivx)+iadj + if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx)) + if (nssb(ivx) .gt. 0) then +c +c Cycle thru non-rest notes in SSBG, looking for bmstrts. +c + isssb = 0 + do 4 inb = 2, nnb + if (btest(nacc(ivx,ipb(inb)),21)) then +c +c Beam segment start. New start level + isssb = isssb+1 + lev1ssb(ivx,isssb) = + * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac + end if +4 continue + end if + end if + end if + iadj = igetbits(islur(ivx,ipb1),2,27) + addbrack = .false. + if (btest(ipl(ivx,ipb1),30)) then +c +c Check for altered starting polarity. Only in forced beams. Nominal start +c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). +c + if (ulq(ivx,ibc).eq.'u' .and. + * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'loff{' + else + notexq = notexq(1:lnote)//sq//'loff{' + end if + lnote = lnote+6 + addbrack = .true. + else if (ulq(ivx,ibc).eq.'l' .and. + * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'roff{' + else + notexq = notexq(1:lnote)//sq//'roff{' + end if + lnote = lnote+6 + addbrack = .true. + end if +c +c Check end level for possible flipping in forced beam. Have to do it +c here since with multiple voices, xelsk will not be preserved. +c + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then + bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc)) + else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then + bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc)) + end if + end if + call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote) +c +c Put in name of start level and slope, after correcting nolev1 if xtup +c started with a rest. +c + if (ixrest(ivx).eq.2) nolev1(ivx) = + * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac) + call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1)) + if (islope(ivx) .lt. 0) then + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+4+lnoten + write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}' + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+1+lnoten + write(notexq(lnote:lnote),'(i1)')islope(ivx) + end if +c +c Check for beam-thk fine-tuning +c + if (iadj .gt. 0) then + do 1 imp = multb+iadj , multb+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote) +1 continue + end if +c +c If we shifted, must close with right bracket +c + if (addbrack) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Get 'floor' zmin for figures +c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height +c won't be adjusted. If anyone ever needs that, need to duplicate this +c functionality up above, before exiting. +c + if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then + if (ivx .eq. 1) then + ivf = 1 + else + ivf = ivxfig2 + end if + zmult = 1.2*(multb-1) + ymin = 100. + do 3 inb = 1, nnb + if (isfig(ivf,ipb(inb))) then + if (ulq(iv,ibc) .eq. 'u') then + ybot = nolev(iv,ipb(inb)) + else + ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx) + * -stemlen-zmult + end if + ymin = min(ymin,ybot) + end if +3 continue + maxdrop = ncmid(iv,ipb1)-4-ymin+5.01 + ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop) + end if +c +c Compute ornament levels if needed +c + NomOrnLev = ncmid(iv,ipb1)+5 + iorn = 0 + do 8 inb = 1 , nnb + ip = ipb(inb) + if (.not.btest(iornq(ivx,ip),23)) go to 8 + if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then +c +c letter-dynamic or hairpin ending under down-beamed +c + iorn = iorn+1 + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + else if (.not.btest(ipl(ivx,ip),10)) then +c +c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD +c +c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if +c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) +c + if (ulq(ivx,ibc).eq.'u' .and. + * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then + iorn = iorn+1 + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + end if + else +c +c In a chord. Orn may be on main note or non-main or both. Set ihornb if +c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note +c + do 10 icrd1 = 1 , ncrd + if (iand(255,icrdat(icrd1)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11 +10 continue +11 continue +c +c Find outermost note, min or max depending on beam direction ulq. xto is true +c if there's an ornament on that note. Expand orn list to include ._, since if +c on extreme chord note in beam, will move. +c So ornaments are all except 0,4,13 (,g,) +c + levx = nolev(ivx,ip) + xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0 + icrdx = 0 + do 12 icrd = icrd1 , ncrd + if (iand(255,icrdat(icrd)) .ne. ip .or. + * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13 + levc = iand(127,ishft(icrdat(icrd),-12)) + if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or. + * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then + levx = levc + icrdx = icrd + xto = iand(icrdorn(icrd),4186094).gt.0 + end if +12 continue +13 continue +c +c If there's orn on extreme note, do stuff +c + if (xto) then + iorn = iorn+1 + if (ulq(ivx,ibc) .eq. 'u') then + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + else + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + end if + if (icrdx .eq. 0) then +c +c Affected ornament is on main note +c + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + else + icrdorn(icrdx) = ibset(icrdorn(icrdx),22) + end if + end if + end if +8 continue +c +c Henceforth nornb will be a counter. +c + if (iorn .gt. 0) nornb(ivx)=1 + if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0 + return + end + block data + parameter (nm=24) + common /comtol/ tol + common /comtrans/ cheadq + common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + logical usefig + common /comstart/ facmtr + character*60 cheadq + character*120 instrq,titleq,compoq + logical headlog + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /combmh/ bmhgt,clefend + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) +c + data tol /.001/ + data cheadq + * /' '/ + data gslfac /9./ + data instrq,titleq,compoq,headlog /3*' ',.false./ +c +c meter space (pts) = xb4mbr = musicsize*facmtr +c + data facmtr /0.55/ + data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt + * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 , + * .7,.7 ,.9 ,.5 ,2.3 ,1.1 / + data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac + * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 / + data rtshfac / 1.0 / + data isize /nm*0/ +c +c From other +c + data ptheight,widthpt, + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh + * / 740. , 524. , + * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12., + * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 / + data fracsys /30*0./ + data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1, +c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3, + * -0.3,0.3 / + data kbdrests /.false./, + * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/ + data EarlyTransOn, LaterInstTrans /2*.false./ + data iInstTrans /nm*0/ + end + subroutine catspace(space,squez,nnsk) + parameter (nkb=3999,maxblks=4000) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + logical gotclef + do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1 + if (abs(space-durb(iptr)) .lt. tol) then + if (abs(squez-sqzb(iptr)) .lt. tol) then +c +c Increment pre-existing entry +c + nnpd(iptr) = nnpd(iptr)+nnsk + return + end if + end if +16 continue +c +c Didn't find current duration & squez, so add a new entry. +c No particular reason to keep in order, so add at the end. +c + nnpd(nptr(ibarcnt+1)) = nnsk + durb(nptr(ibarcnt+1)) = space + sqzb(nptr(ibarcnt+1)) = squez + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + return + end + character*1 function chax(n) +c +c The only reason for this seemingly do-nothing function is to get around an +c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! +c + chax = char(n) + return + end + subroutine checkdyn(lineq,iccount,ibar) + character*128 lineq + character*1 durq,chax + character*4 dynsymq + logical txtdyn + txtdyn = .false. +c +c On entry, iccount is on "D" +c + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c Dynamic text +c + iend = index(lineq(iccount+2:128),'"') + if (iend .eq. 0) then + call errmsg(lineq,iccount+1,ibar, + * 'Dynamic text must be terminated with double quote!') + call stop1() + end if +c +c Set iccount to character after 2nd ", and set ipm +c + iccount = iccount+iend+2 + ipm = index('- +',lineq(iccount:iccount)) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "-", "+", or blank here!') + call stop1() + end if + else +c +c Expect ordinary dynamic +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) + if (ipm .gt. 0) go to 2 +1 continue +2 continue + if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then + call errmsg(lineq,iend-1,ibar, + * 'Wrong length for dynamic mark!') + call stop1() + end if + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ', + * dynsymq)+3)/4 + if (idno .eq. 0) then + call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!') + call stop1() + end if + iccount = iend + end if + if (ipm .ne. 2) then +c +c There is a vertical shift, have "+" or "-" +c + iccount = iccount+1 + if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected integer here for vertical offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + if (idno .gt. 63) then + call errmsg(lineq,iccount-1,ibar, + * 'Vertical offset for dynamic mark must be (-63,63)!') + call stop1() + end if + ipm = index('- +',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "+", "-", or blank here!') + call stop1() + end if + if (ipm .ne. 2) then +c +c There is a horizontal shift +c + iccount = iccount+1 + if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected number here for horizontal offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + if (idno .gt. 255) then + call errmsg(lineq,iccount-1,ibar, + * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!') + call stop1() + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibar, + * 'There should be a blank here!') + call stop1() + end if + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + return + end + subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) +c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, +c * icashft) + logical found1,iscacc,isarp,btest + integer icrdat(193) + found1 = .false. +c +c icashft will be max left shift of accid's in chord notes. +c Used only for spacing checks. +c Will include left shift of chord note itself. +c Rezero after use. +c + do 18 icrd = 1 , ncrd +c +c This if block cycles thru all chord notes on ivx,ip; then returns. +c + if (iand(255,icrdat(icrd)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then + found1 = .true. + iscacc = iscacc .or. + * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) +c +c Accid on this chord note, and it's not midi-only. +c +c irshft = igetbits(icrdot(icrd),7,20) +cc +cc Include increment for notehead shift +cc +c if (btest(icrdat(icrd),23)) then +c if (irshft .eq. 0) then +c irshft = 44 +c else +c irshft=irshft-20 +c end if +c end if +c if (irshft .ne. 0) then +cc +cc Accid on chord note is shifted. Include only left shift, in 20ths. +cc +c if (irshft .lt. 64) icashft = max(icashft,64-irshft) +c end if +c end if + isarp = isarp .or. btest(icrdat(icrd),25) + else if (found1) then + return + end if +18 continue + return + end + subroutine chkimidi(icm) + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + if (imidi(icm) .ge. mv) then + print* + print*,'Midi file is too long! It will be corrupted or worse' + write(*,'(a6,2x,4i8)') + * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3) + end if + return + end + subroutine chklit(lineq,iccount,literr) + character*128 lineq + character*1 charq,chax + literr = 0 + itype = 1 +17 call g1etchar(lineq,iccount,charq) + if (charq .eq. chax(92)) then + itype = itype+1 +c if (itype .eq. 2) then +c if (iccount .ne. 2 ) then +cc +cc type 2 or 3 tex string not starting in column 1 +cc +c literr = 3 +c return +c end if +c else if (itype .gt. 3) then + if (itype .gt. 3) then + literr = 1 + return + end if + go to 17 + end if + lenlit = itype +18 call g1etchar(lineq,iccount,charq) + if (charq.eq.chax(92)) then + call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then +c +c Starting a new tex command withing the string +c + lenlit = lenlit+2 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + else + lenlit = lenlit+1 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + return + end + subroutine chkpm4ac(lineq,iccount,nacc,moved) +c +c Called after getting +/-/ in a note (not rest). iccount is on the +-<>. +c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits +c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed +c numbers. If moved=.true., iccount on exit is on end of last number. +c If moved=.false., iccount still on +/- +c + logical moved,ishorz + character*128 lineq + character*1 durq + if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and. + * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then +c +c Prior char was accid & next is #; this may be start of accidental shift. +c Must test for "." above in case we get "<" or ">" +c + ipm = index('- +< >',lineq(iccount:iccount))-2 + if (lineq(iccount+1:iccount+1).eq.'.' .and. + * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then +c +c Rare case of [accid][+/-].[letter]. Bail out +c + moved = .false. + return + end if + ishorz = ipm .gt. 1 +c +c Save iccount in case it's not accid shift and we have to reset. +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (ishorz .or. index('+-',durq).gt.0) then +c +c This has to be accidental shift. Set vert. shift. +c + if (.not.ishorz) then +c +c +/- syntax, both shifts set, vertical first +c + call setbits(nacc,6,4,int(ipm*fnum+32.5)) + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else +c +c syntax, only horiz set +c + ipm = ipm-3 + end if +c +c Set horiz. shift +c + call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35))) + iccount = iccount-1 + moved = .true. + else +c +c False alarm. Reset everything and flow onward +c + moved = .false. + iccount = icsav + end if + else +c +c Either prior char was not 'sfn' or next was not digit, so take no action +c + moved = .false. + end if + return + end + subroutine clefsym(isl,notexq,lnote,nclef) +c +c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. +c + character*(*) notexq + character*1 chax + nclef = iand(ishft(isl,-12),7) + if (nclef .eq. 0) then +c +c treble +c + nlev = 2 + else if (nclef .gt. 6) then +c +c French violin +c + nlev = 0 + else if (nclef .lt. 5) then +c +c C-clef +c + nlev = 2*nclef-2 + else +c +c F-clef +c + nlev = 2*nclef-6 + end if + notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7)) + * //chax(48+nlev) + lnote = 10 + return + end + subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime, + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c micrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c segrb(1|2,.) x|y-coord of right-bdry segment +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c icrdot0 = top-down level-rank of main note among accid-notes +c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes +c twooftwo will be true 2nd time thru; signal to store shifts w/ notes +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50) + integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50), + * isetshft(10),ksegrb0(50) + logical lasttime,mainnote,twooftwo + data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 / + data segar / +c +c Fancy sharp boundary. fl,sh,na,dfl,dsh +c + * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2, +c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , +c meas value for y, natural is 1.6 + * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2, + * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / + data segal / +c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , +cc (meas. value is 3.08) ^^^^ +cc Raise top of flat so it interferes with bottom of sharp + * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2, + * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2, + * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / +c +c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) +c + data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 / +c +c Set up barrier segrb(iseg,ipoint) to define coords of corner points +c on stem+notes +c + do 11 iseg = 1 , nsegrb0 + segrb(1,iseg) = segrb0(1,iseg) + segrb(2,iseg) = segrb0(2,iseg) + ksegrb(iseg) = ksegrb0(iseg) +11 continue + nsegrb = nsegrb0 + rmsshift = 0. + shiftmin = 1000. + do 1 iwa = 1 , naccid +c +c Initialize shift for this note +c + shift = 0. + mainnote = micrd(iwa).eq.0 + isetshft(iwa) = -1 +c +c Get note level and accidental type +c + if (mainnote) then + nolev = nolevm + iacctype = iacctbl(igetbits(nacc,3,0)) + else + nolev = igetbits(icrdat(micrd(iwa)),7,12) + iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20)) + end if +c +c Cycle thru segments on right edge of this accidental +c + do 2 isega = 1 , nsegar(iacctype)-1 + ybotaseg = nolev+segar(iacctype,2,isega) + ytopaseg = nolev+segar(iacctype,2,isega+1) +c +c Cycle thru segments of right-hand barrier +c + do 3 isegrb = 1 , nsegrb-1 +c +c Must find all barrier segments that start below ytopseg & end above ybotseg +c + if (segrb(2,isegrb) .lt. ytopaseg) then +c +c Barrier seg starts below top of accid +c Check if barrier seg ends above bottom of accid +c + if (segrb(2,isegrb+1) .gt. ybotaseg) then + if (shift .gt. + * segrb(1,isegrb)-segar(iacctype,1,isega)) then + shift = segrb(1,isegrb)-segar(iacctype,1,isega) +c +c Record the cause of the shift +c + isetshft(iwa) = ksegrb(isegrb) + end if + end if +c +c Does barrier segment end above top of accid seg? +c + if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4 + end if +3 continue +4 continue +2 continue + if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001 + * .and. .not.lasttime) then +c if (nolev .eq. levmaxacc) then + if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then + rmsshift = 1000. + return + end if +c +c Does the following properly account for left-shifted noteheads? +c +c Top-down rank of this note we just shifted +c + if (mainnote) then + irank = icrdot0 + else + irank = igetbits(icrdot(micrd(iwa)),3,27) + end if +c +c Compare level-rank of this note vs. that of note that caused the shift. +c This has effect of checking for basic interferences from top down. +c +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c + if (isetshft(iwa) .lt. 0) then + iranksetter = 0 + else if (isetshft(iwa) .eq. 0) then + iranksetter = icrdot0 + else + iranksetter = igetbits(icrdot(isetshft(iwa)),3,27) + end if + if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then + rmsshift = 1000. + return + end if + end if + rmsshift = rmsshift+shift**2 + if (lasttime .and. abs(shift).gt..0001) then + if (mainnote) then + if (.not.btest(nacc,29)) go to 10 + else + if (.not.btest(icrdat(micrd(iwa)),29)) go to 10 + end if +c +c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there +c was a manual shift but auto-shift was zero, will not come thru here, but shift value +c will be left intact. +c + if (mainnote) then + shift = shift+.05*(igetbits(nacc,7,10)-107) + else + shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107) + end if +10 continue + if (twooftwo) then +c +c Record the shift for this accidental +c + if (shift .lt. -5.35) then + call printl(' ') + call printl('WARNING: auto-generated accidental '// + * 'shift too big for PMX, ignoring') + else + ishift = nint(20*(shift+5.35)) + if (mainnote) then + call setbits(nacc,7,10,ishift) + else + call setbits(icrdot(micrd(iwa)),7,20,ishift) + end if + end if + else +c +c This is the earlier call to precrd, so need minimum shift +c + shiftmin = min(shiftmin,shift) + end if + end if +c +c Bail out if this is the last accidental to check +c + if (iwa .eq. naccid) go to 1 +c +c Add this accidental to the right barrier! Count down from highest barrier segment, +c find 1st one starting below top of accid, and first one starting below bot. +c + do 5 ibelowtop = nsegrb , 1 , -1 + if (segrb(2,ibelowtop) .lt. + * nolev+segal(iacctype,2,nsegal(iacctype))) then + do 9 ibelowbot = ibelowtop , 1 , -1 + if (segrb(2,ibelowbot) .lt. + * nolev+segal(iacctype,2,1)) go to 6 +9 continue + print*,'Oops2!' + call stop1() + end if +5 continue + print*,'Ugh0! in crdaccs' + call stop1() +6 continue + netgain = nsegal(iacctype)-ibelowtop+ibelowbot +c +c Shift high segments up +c + if (netgain .ge. 0) then + do 7 isegrb = nsegrb , ibelowtop+1 , -1 + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +7 continue +c +c Set up 1st segment above accid +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + else +c +c netgain<0, must remove segments. Use same coding but reverse order, +c work from bottom up +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + do 12 isegrb = ibelowtop+1 , nsegrb + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +12 continue + end if +c +c Insert new segments +c + do 8 isega = 1 , nsegal(iacctype)-1 + segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega) + segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega) + if (mainnote) then + ksegrb(ibelowbot+isega) = 0 + else + ksegrb(ibelowbot+isega) = micrd(iwa) + end if +8 continue +c +c Update number of barrier segments +c + nsegrb = nsegrb+netgain +cc +cc Temporary printout for boundary segments as built up +cc +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) +cc +1 continue ! next accidental + if (lasttime .and. .not.twooftwo) then +c +c This is the final call on the pre-ask pass, so compute left-shift rqmt. +c + icashft = nint(-20*shiftmin) + end if +cc +cc Temporary printout for boundary segments +cc +c if (twooftwo) then +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa),isetshft(iwa),iwa=1,naccid) +c end if +cc + return + end + subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm, + * levmaxacc,levminacc,icrdot0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c +c This is called once per multi-accidental chord. In here, loop over all +c permutations of the order of accidental as stored in kicrd. Each time thru +c loop, call crdacc once, get rms shift. Only save permutation and rms value +c if it is less than old value. +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c Make consistent? 120106 +c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + real*4 segrb0(2,50) + logical btest,tagged,manual,lshift,twooftwo +cc +cc Temporary printout of level-rankings +cc +c write(15,'()') +c do 98 iacc = 1 , naccid +c if (kicrd(iacc) .eq. 0) then +c write(15,'(3i5)')nolevm,icrdot0 +c else +c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), +c * igetbits(icrdot(kicrd(iacc)),3,27) +c end if +c98 continue +cc +c +c Initialize right-barrier +c + segrb0(1,1) = 0. + segrb0(2,1) = -1000. + segrb0(1,2) = 0. + segrb0(2,2) = 1000. + nsegrb0 = 2 + ksegrb0(1) = -1 + ksegrb0(2) = -1 +c +c Search for left-shifted notes, Make up the initial right-barrier, which +c will be good for all permutations. +c irest()(27) is set if any notes are left-shifted +c Must use ALL chord notes, not just ones w/ accid's. +c + if (btest(irest,27)) then + do 15 icrd = icrd1-1, icrd2 + if (icrd .eq. icrd1-1) then +c +c Main note +c +c lshift = btest(ipl,8) + lshift = btest(ipl,8) .or. btest(nacc,31) + if (lshift) nolev = nolevm + else +c +c Chord note +c + lshift = btest(icrdat(icrd),23) +c if (lshift) nolev = igetbits(icrdat(icrd),7,12) + if (lshift) then + nolev = igetbits(icrdat(icrd),7,12) + if (btest(nacc,31) .and. nolev.eq.nolevm+1) then +c +c This note is not really shifted, It is the upper of a 2nd with the main +c note on an upstem, and Main note must be shifted. +c nacc(31) signals the real truth. +c + lshift = .false. + end if + end if + end if + if (lshift) then + do 16 isegrb = 1 , nsegrb0-1 + if (segrb0(2,isegrb+1) .gt. nolev-1) then +c +c Add this notehead to the right boundary here. Move all higher segs up 2. +c + do 17 iiseg = nsegrb0 , isegrb+1 , -1 + segrb0(1,iiseg+2) = segrb0(1,iiseg) + segrb0(2,iiseg+2) = segrb0(2,iiseg) + ksegrb0(iiseg+2) = ksegrb0(iiseg) +17 continue + go to 18 + end if +16 continue +18 continue +c +c Insert notehead into list. Set kseg=-2 to signal notehead shift. +c + iiseg = isegrb+1 + segrb0(1,iiseg) = -1.2 + segrb0(2,iiseg) = nolev-1. + ksegrb0(iiseg) = -2 + segrb0(1,iiseg+1) = 0. + segrb0(2,iiseg+1) = nolev+1. + ksegrb0(iiseg+1) = -1 + nsegrb0 = nsegrb0+2 + end if +15 continue + end if +c +c Done setting right barrier for left-shifted noteheads +c + tagged = .false. + manual = .false. +c +c Preprocess to check for manual shifts. +c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then +c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, Observe all manual shifts. +c End if +c End if +c + maxmanshft = 0 + do 13 i = 1 , naccid + if (kicrd(i) .eq. 0) then +c +c Main note +c + manshft = igetbits(nacc,7,10) + if (manshft .ne. 0) then + manual = .true. + if (btest(nacc,29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + else +c +c Chord note +c + manshft = igetbits(icrdot(kicrd(i)),7,20) + if (manshft .ne. 0) then + manual = .true. + if (btest(icrdat(kicrd(i)),29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + end if +13 continue + if (manual) then + if (tagged) then +c +c zero out all untagged shifts +c + do 14 i = 1 , naccid + if (kicrd(i) .eq. 0) then + if (.not.btest(nacc,29)) call setbits (nacc,7,10,0) + else + if (.not.btest(icrdat(kicrd(i)),29)) + * call setbits (icrdot(kicrd(i)),7,20,0) + end if +14 continue + else +c +c There are manual shifts but none tagged. Only proceed if "Ao" was entered +c + if (.not.btest(nacc,28)) then + icashft = maxmanshft + return + end if + end if + end if + if (btest(nacc,28)) then +c +c Take the accidentals in order as originally input, then exit. +c + call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return +c end if + else if (naccid .eq. 3) then +c +c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd +c then place in order top, bottom, middle. +c + do 20 i = 1 , 3 + if (kicrd(i) .eq. 0) then + irank = icrdot0 + nolev = nolevm + else + irank = igetbits(icrdot(kicrd(i)),3,27) + nolev = igetbits(icrdat(kicrd(i)),7,12) + end if + if (irank .eq. 1 ) then + micrd(1) = kicrd(i) + else + micrd(5-irank) = kicrd(i) + end if + if (irank .eq. 2) then + levmidacc = nolev + end if +20 continue + if (levmaxacc.ne.levmidacc+1 .and. + * levmidacc.ne.levminacc+1) then + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end if + end if + rmsmin = 100000. +c +c Initialize permutation array +c + do 7 i = 1 , naccid + iperm(i) = i +7 continue +c +c Start looping over permutations +c + do 8 ip = 1 , 5041 + if (ip .ne. 1) then +c +c Work the magic algorithm to get the next permutation +c + do 1 k = naccid-1 , 1 , -1 + if (iperm(k) .le. iperm(k+1)) go to 2 +1 continue +c +c If here, we just got the last permutation, so exit the loop over permutations +c + go to 10 +2 continue + do 3 j = naccid , 1 , -1 + if (iperm(k) .le. iperm(j)) go to 4 +3 continue +4 continue + it = iperm(j) + iperm(j) = iperm(k) + iperm(k) = it + is = k+1 + do 5 ir = naccid , 1 , -1 + if (ir .le. is) go to 6 + it = iperm(ir) + iperm(ir) = iperm(is) + iperm(is) = it + is = is+1 +5 continue +6 continue + end if +c +c New we have a permutation. Take icrd values out of kicrd and put them into +c micrd in the order of the permutation +c + do 9 i = 1 , naccid + micrd(i) = kicrd(iperm(i)) +9 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false., + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +cc +cc Temporary printout +cc +c write(15,*)'perm done, rmsshift:',rmsshift +cc + if (rmsshift .lt. rmsmin) then +c +c Save this permutation, reset minrms +c + do 11 i = 1 , naccid + ipermsav(i) = iperm(i) + rmsmin = rmsshift +11 continue + end if +8 continue + print*,'Should not BEEEEEE here!' + call stop1() +10 continue +c +c Done looping, get info for the final choice +c + do 12 i = 1 , naccid + micrd(i) = kicrd(ipermsav(i)) +12 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end + subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut) + character*1 sq,chax + character*3 acsymq + character*8 noteq + character*79 notexq + logical btest,caut + sq = chax(92) + if (ihshft .eq. -107) ihshft=0 +cc +cc If main note shifted left, so shift accid. Terminate below, when acc. is done. +cc + if (ihshft .ne. 0) then +c +c Accid must be shifted horizontally +c + if (ihshft .lt. 0) then + notexq = sq//'loffset{' + ihshft = -ihshft + else + notexq = sq//'roffset{' + end if + hshft = .05*ihshft + if (hshft .lt. 1.) then + write(notexq(10:12),'(f3.2)')hshft + lnote = 12 + else + write(notexq(10:13),'(f4.2)')hshft + lnote = 13 + end if + notexq = notexq(1:lnote)//'}{'//sq + lnote = lnote+3 + else + notexq = sq + lnote = 1 + end if + if (btest(nacc,3)) then + notexq = notexq(1:lnote)//'big' + lnote = lnote+3 + end if + if (caut) then +c +c Cautionary accidental. Need to define bigcna,... in pmx.tex +c + notexq = notexq(1:lnote)//'c' + lnote = lnote+1 + end if + call accsym(nacc,acsymq,lacc) + notexq = notexq(1:lnote)//acsymq(1:lacc) + lnote = lnote+lacc + noleva = nolev + if (ivshft .ne. 0) noleva = noleva+ivshft-32 + call notefq(noteq,lnoten,noleva,ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihshft .ne. 0) then +c +c Terminate horizontal shift +c + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + return + end + subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt, + * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen, + * dotxtup,nacc) + parameter (nm=24,mv=24576) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical lowdot,dotxtup + integer*4 ihornb(nm,24),nornb(nm) + character*1 ulq(nm,9),chax + character*7 nosymq + character*8 noteq + character*79 notexq,outq + character*80 soutq + logical btest,isleft,isright,beamon + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c This subr. once produced notexq for entire chord. 10/18/97 altered to write +c chord notes as we go. 10/22/97 find range of icrd first. +c 2/25/98 moved rangefinding to precrd so done before slurs, so now +c on entry, icrd1, icrd2 define range of icrd for this chord. +c +c Set counter (for this note) for chord notes present. Set notmain=T. +c Will test for notmain=.true. in addmidi to tell whether to save pitch. +c + nmidcrd = 0 + notmain = .true. + crdacc = .false. + do 5 icrd = icrd1 , icrd2 + lnote = 0 + nolev = igetbits(icrdat(icrd),7,12) +c +c 3/8/03 save original pitch to use in midi, in case 2nds alter things. +c + nolevo = nolev +c +c Check for special situations with 2nds (see precrd). +c + if (btest(nacc,30)) then + if (nolev .eq. nolevm-1) nolev = nolevm + else if (btest(nacc,31)) then + if (nolev .eq. nolevm+1) nolev = nolevm + end if +c +c Lower dot for lower-voice notes?. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest (cannot be a rest in a chord!) +c. 5. Flag (lowdot) is set to true +c + if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then + if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then + if (btest(icrdat(icrd),26)) then +c +c Note already in movdot list. Drop by 2. +c + call setbits(icrdot(icrd),7,0, + * igetbits(icrdot(icrd),7,0)-20) + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3)) + end if + end if + end if + if (btest(icrdat(icrd),26)) then +c +c Move the dot. +c + updotc = 0.1*(iand(127,icrdot(icrd))-64) + rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64) + call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3)) + end if + isleft = btest(icrdat(icrd),23) + isright = btest(icrdat(icrd),24) +c +c Check for ornament in chord. +c + if (icrdorn(icrd) .gt. 0) then + call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq, + * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout, + * ip,0,beamon,.true.) +c +c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, +c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, +c * notcrd,beamon,iscrd) +c + call addstr(outq,lout,soutq,lsout) + end if +c +c Chord-note symbol. First check for breve +c + if (nodu .eq. 128) then + nosymq = chax(92)//'zbreve' + lsym = 7 + else +c +c Not a breve chord. Get first letters in chord-note symbol +c + if (isleft) then + nosymq = chax(92)//'l' + else if (isright) then + nosymq = chax(92)//'r' + else + nosymq = chax(92)//'z' + end if + if (nodu .ge. 64) then + nosymq = nosymq(1:2)//'w' + else if (nodu .ge. 32) then + nosymq = nosymq(1:2)//'h' + else + nosymq = nosymq(1:2)//'q' + end if + if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then + lsym = 3 + else if (.not.btest(islur,3) .or. dotxtup) then +c +c Single dot +c + nosymq = nosymq(1:3)//'p' + lsym = 4 + else +c +c Double dot +c + nosymq = nosymq(1:3)//'pp' + lsym = 5 + end if + end if + if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then +c +c Accidental and not MIDI-only. Build up bits 0-3 of nacc +c + nactmp = igetbits(icrdat(icrd),3,20) +c +c Kluge for bigness. Only means 'As' has not been issued +c + if (bacfac .ne. 1.e6) nactmp = nactmp+8 + call doacc(igetbits(icrdot(icrd),7,20)-107, + * igetbits(icrdot(icrd),6,14), +c * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) +c Get original nolev, not altered to deal with 2nds + * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12), +c * ncmid(iv,ip)) + * ncmid(iv,ip),btest(icrdat(icrd),31)) + notexq = notexq(1:lnote)//nosymq + crdacc = .true. + else + notexq = nosymq + end if + lnote = lnote+lsym +c +c Get note name (again if accid, due to possible octave jump) +c + call notefq(noteq,lnoten,nolev,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) +c +c Put in note name +c + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + if (btest(icrdat(icrd),25)) then +c +c Arpeggio signal +c +c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout) + end if + call addstr(notexq,lnote,soutq,lsout) + if (ismidi) then +c +c Here is where we collect MIDI pitch info for the chord note. By checking +c notmain, addmidi(...) knows to just compute the +c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() +c for MAIN note, will put in note codes for all chord notes + main note. +c + kv = 1 + if (ivx .gt. iv) kv=2 + nmidcrd = nmidcrd+1 + if (nmidcrd .gt. 20) then + print* + print*,'21 chord notes is too many for midi processor' + call stop1() + end if +c +c Use original saved pitch level, unaltered by 2nds logic. +c +c call addmidi(midchan(iv,kv),nolevo, + call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), + * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) + end if +5 continue + notmain = .false. + return + end + subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv, + * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout) + parameter (nm=24) +c +c Inputs are array *elements* except ihornb,nornb,ulq +c + common /commus/ musize,whead20 + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,beamon,upstem,nostem + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 udqq,chax,ulq(nm,9) + character*4 dynstrq + character*5 numpq + character*48 dyntablq,tempq + character*79 notexq + character*80 soutq + integer*4 ihornb(nm,24),nornb(nm),idynn(10) + data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/ + numdyn = 0 +c +c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values +c in idynn(1...4) +c + do 1 idyn = 1 , ndyn +c ivxtent = iand(idyndat(idyn),15) + ivxtent = iand(idyndat(idyn),15) + * +16*igetbits(idynda2(idyn),1,10) + if (ivxtent .eq. ivx) then + iptent = igetbits(idyndat(idyn),8,4) + if (iptent .eq. ip) then + numdyn = numdyn+1 + idynn(numdyn) = idyn + else if (iptent .gt. ip) then +c +c I don't think there are any more possible for this ivx,ip, so exit loop +c + go to 2 + end if +c else if (ivxtent .gt. ivx) then +c go to 2 + end if +1 continue +2 continue +c +c At this point there is a list of idyn's in idynn(1...numdyn) +c Compute level, and stem-dir'n-based horizontal tweaks +c + hoffsd = 0. +c +c Set upstem to false as default +c + upstem = .false. + if (btest(irest,0)) then +c +c It's a rest. Assume it doesn't go below the staff +c + lbot = ncm-4 + else if (.not.beamon) then + if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + if (.not.btest(ipl,10)) then + lbot = min(nolev-7,ncm-4) + else + lbot = min(minlev-7,ncm-4) + end if + end if + else + if (ulq(ivx,ibmcnt) .eq. 'u') then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + lbot = ihornb(ivx,nornb(ivx))+1 + if (lbot .eq. 1) then +c +c Kluge for non-beamed, down xtup, for which ihorb was never set. +c Assumes stem is shortened. +c + lbot = nolev-5 + end if + nornb(ivx) = nornb(ivx)+1 + end if + end if + lbot = lbot-5 + jtxtdyn1 = 1 +c +c Now ready to loop over current dyn's +c + do 3 icntdyn = 1 , numdyn + idynd = idyndat(idynn(icntdyn)) + idynd2 = idynda2(idynn(icntdyn)) + idno = igetbits(idynd,4,12) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynd2,1,10) +c +c Build the command into notex in stages. Insert name & rq'd args in order: +c +c Command name +c hpstrt, hpcend, hpdend, pmxdyn +c ivx +c X X X +c level +c X X X +c hoff +c X X X X +c d-mark +c X +c + if (idno .eq. 0) then +c +c Text-dynamic +c + notexq = chax(92)//'txtdyn' + lnote = 7 + else if (idno .le. 12) then +c +c Letter-group +c + notexq = chax(92)//'pmxdyn' + lnote = 7 + else if (fontslur) then + lnote = 7 + if (idno .eq. 13) then +c +c Start a hairpin +c + notexq = chax(92)//'hpstrt' + else if (idno .eq. 14) then +c +c End crescendo +c + notexq = chax(92)//'hpcend' + else +c +c End decrescendo +c + notexq = chax(92)//'hpdend' + end if + else +c +c Postscript hairpins +c + lnote = 7 + if (idno .eq. 13) then + notexq = chax(92)//'Icresc' + else if (idno .eq.14) then + notexq = chax(92)//'Idecresc' + lnote = 9 + else + notexq = chax(92)//'Tcresc' + end if + end if + if (idno .ge. 13) then +c +c Put in voice number +c + if (ivx .le. 9) then + notexq = notexq(1:lnote)//char(48+ivx) + lnote = lnote+1 + else if (ivx .le. 19) then + notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}' + lnote = lnote+4 + end if + end if +c +c Begin setting level +c + lbot1 = lbot + if (idno.gt.0 .and. idno.le.5) then +c +c All letters are short so raise a bit. +c + lbot1 = lbot1+1 + else if (idno .ge. 13) then + lbot1 = lbot1+2 + end if +c +c Convert so reference is bottom line +c + lbot1 = lbot1-ncm+4 + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. Save level and user-tweak before applying user tweak. +c + levdsav(ivx) = lbot1 + levhssav(ivx) = 0 + if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17) + else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then +c +c Hairpin end; Compare level with saved start level before user-tweaks +c + lbot1 = min(lbot1,levdsav(ivx)) +c +c Save pre-tweak level +c + lpretweak = lbot1 + end if +c +c Check for user-defined vertical tweak +c + if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17) +c +c Now horizontal stuff +c + hoff = hoffsd +c +c Some special horizontal tweaks +c + if (upstem .and. idno.gt.0 .and. + * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4 +c +c User-defined tweaks +c + if (btest(idynd2,0)) + * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1 + if (numdyn .gt. 1) then +c +c Horizontal-interaction-based tweaks. +c +c Cases: +c numdyn type1 type2 type3 data used +c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) +c 2 hrpnend wrd-grp - ivowg,hoh2 +c 2 hrpnend hrpnstrt - hoh2h1(1...2) +c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 +c + if (idno.gt.0 .and. idno.le.12) then +c +c Word-group, may need vertical tweak to line up. +c + lbot1 = lbot1+ivowg(idno) +c +c Protecting against hp start-stop on same note +c + else if (((fontslur.and.idno.ge.14).or.idno.eq.15) + * .and. icntdyn.lt.numdyn) then +c +c Hairpin ending, check next type +c + if ((fontslur .and. + * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. (.not.fontslur .and. + * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. + * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14)))) + * then +c +c Hairpin end then hairpin start, no words, (remember dealing with end now) +c + hoff = hoff+hoh2h1(1) + else +c +c Hairpin end then word-group, need idno for w-g to set hp offset +c + hoff = hoff + + * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12)) + end if +c +c Protecting against hp start-stop on same note +c + else if (icntdyn.gt.1 .and. idno.gt.0 .and. + * ((fontslur.and.idno.lt.14).or. + * (.not.fontslur.and.idno.lt.15))) then +c +c Hairpin start, check prior type +c + if ((fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14) + * .or. + * (.not.fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15)) + * then +c +c Hairpin end then hairpin start, (remember dealing with start now) +c + hoff = hoff+hoh2h1(2) + else +c +c Hairpin start after word-group, need idno for w-g to set hp offset +c + hoff = hoff+ + * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12)) + end if + end if + end if +c +c End of if-block for 2- or 3-way interactions. +c + if ((.not.fontslur) .and. idno.ge.13) +c +c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width +c + * hoff = (hoff+.5)*6./2.5 +c +c Position corrections all done now. Put in the level. +c + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. +c + if (.not.fontslur) then +c +c Postscript hairpin start...inset placeholder for start level. + + notexq = notexq(1:lnote)//'{ }' + lnote = lnote+5 + end if + else +c +c Insert actual level in all cases except hairpin start +c Create string with level in it +c + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Level has now been computed and stored in numpq +c Append the level +c + notexq = notexq(1:lnote)//numpq(1:lnumpq) + lnote = lnote+lnumpq + end if + if (abs(hoff) .lt. .001) then +c +c No horiz offset +c + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else +c +c Horizontal tweak +c + lform = lfmt1(hoff) + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')hoff + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + if (idno .eq. 0) then +c +c text-dynamic. Find the string and append it +c + do 4 jtxtdyn = jtxtdyn1 , ntxtdyn +c ivxip = ivx+16*ip + ivxip = ivx+32*ip + if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5 +4 continue + call printl('Abnormal stop in putdyn') + call stop1() +5 continue + ltxtdyn = lenstr(txtdynq(jtxtdyn),128) +c +c Font size based on musicsize +c + if (musize .eq. 20) then + notexq = notexq(1:lnote)//'{'//char(92)//'medtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 16) then + notexq = notexq(1:lnote)//'{'//char(92)//'normtype' + * //char(92)//'it ' + lnote = lnote+14 + else if (musize .eq. 24) then + notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 29) then + notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' + * //char(92)//'it ' + lnote = lnote+13 + end if + notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn) + * //'}' + lnote = lnote+ltxtdyn+1 +c +c Reset jtxtdyn1 just in case >1 txtdyn on same note. +c + jtxtdyn1 = jtxtdyn+1 + else if (idno .le. 12) then +c +c Letter-group dynamic. Append the letter-group command +c + id = 4*idno + dynstrq = dyntablq(id-3:id) + id = lenstr(dynstrq,4) + notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id) + lnote = lnote+1+id + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) + if ((.not.fontslur).and.idno.eq.15) then +c +c PS slurs on, hairpin is ending. Go back and set height at beginning. +c Add user-defined tweak to default level +c + lbot1 = lpretweak+levhssav(ivx) + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Construct string to search backwards for placeholder +c + if (ivx .le. 9) then + tempq = 'cresc'//char(48+ivx)//'{ }' + ltemp = 11 + else if (ivx .le. 19) then + tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }' + ltemp = 14 + else + tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }' + ltemp = 14 + end if + write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + call backfill(11,tempq,ltemp, + * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq) + end if +3 continue +c +c Shrink arrays, decrease ndyn 111109 +c + do 6 icntdyn = numdyn, 1 , -1 + do 7 jdyn = idynn(icntdyn) , ndyn-1 + idyndat(jdyn) = idyndat(jdyn+1) + idynda2(jdyn) = idynda2(jdyn+1) +7 continue + ndyn = ndyn-1 +6 continue + end + subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl, + * farend, + * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq) +c +c ip will be one LESS than current note, for way-after's before bar-end, +c It is only used to find ig. +c ig is returned to makeabar in case there's a slur that needs to be ended +c + parameter (nm=24) + logical beamon,stemup + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft, + * normsp,farend,fontslur,WrotePsslurDefaults + real*4 ptgr(37) + character*80 soutq + character*128 litq + character*79 notexq + character*20 voltxtq + character*10 figq + character*8 noteq,noteqGA + character*3 acsymq + character*1 sq,chax,udqq,ulq(nm,9) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + sq = chax(92) + isgaft = btest(ipl,29) + iswaft = btest(ipl,31) + normsp = .not. isgaft +c +c Find ig. +c + do 120 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121 +120 continue + print*,'Problem finding grace index in dograce' + stop +121 continue + ngs = ngstrt(ig) + mg = multg(ig) + wheadpt1 = wheadpt*fullsize(ivx) +c +c For way-after-graces at end of bar, must set the octave. +c + if (farend) then + noctup = 0 + if (ncm .eq.23) noctup = -2 + end if + if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then + if (listslur .eq. 16777215) then + print* + print*,'You defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Slur on fore-grace. Get index of next slur not in use, from 23 down. +c + ndxslur = log2(16777215-listslur) + + end if + if (nng(ig) .eq. 1) then +c +c Single grace. +c + if (normsp) then +c +c Anything but GA +c + call addstr(sq//'shlft',6,soutq,lsout) + niptgr = nint(ptgr(ig)) +c +c Empirical tweak for postscript. +c +C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) +c++ + if (niptgr .lt. 10) then + call addstr(chax(48+niptgr)//'{',2,soutq,lsout) + else if (niptgr .lt. 100) then + write(notexq(1:2),'(i2)')niptgr + call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout) + else + print*, + * 'Call Dr. Don if you really want grace note group > 99 pt' + stop + end if + else + call addstr(sq//'gaft{1.5}{',11,soutq,lsout) +c +c GA. Compute aftshft, for later use. +c + aftshft = grafac + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac + aftshft = aftshft*wheadpt + end if + if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then +c +c Start slur on pre-grace. No accounting needed since will be ended very soon. +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Start Postscript slur. +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print slur number, 23-ndxslur +c + lnote = 0 + if (23-ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = chax(71-ndxslur) + lnote = 1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = '{1'//chax(61-ndxslur)//'}' + lnote = 4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = 4 + end if +c if (11-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, +c * soutq,lsout) +c else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), +c * 4+lnoten,soutq,lsout) +c end if + call addstr(notexq(1:lnote)//noteq(1:lnoten), + * lnote+lnoten,soutq,lsout) + if (.not.fontslur) then +c +c Horizontal tweaks for postscript slur on single grace +c + stemup = .true. + if (upg(ig)) then +c +c Check for up-grace + down stem. Get stem direction +c + if (.not.beamon) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev,ncmidx, + * islur,nvmx,ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. tnote.gt.63 + end if + if (stemup) then + call addstr('{-.3}',5,soutq,lsout) + else + call addstr('{-.8}',5,soutq,lsout) + end if + end if + end if + if (naccg(ngs) .gt. 0) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c +c Save for checking octave shifts in GA +c + if (isgaft) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc)// + * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if + if (slashg(ig)) then + notexq = sq//'grc' + lnote = 4 + else if (mg .eq. 0) then + notexq = sq//'zq' + lnote = 3 + else + notexq = sq//'zc' + do 61 i = 2 , mg + notexq = notexq(1:i+1)//'c' +61 continue + lnote = mg+2 + end if + if (upg(ig)) then + notexq = notexq(1:lnote)//'u' + else + notexq = notexq(1:lnote)//'l' + end if + call addstr(notexq,lnote+1,soutq,lsout) + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c + if (isgaft .and. naccg(ngs).eq.0) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call addstr(noteq,lnoten,soutq,lsout) + if (slashg(ig)) call addstr(sq//'off{-'//sq// + * 'noteskip}',16,soutq,lsout) +c +c Above code needed since slashg causes spacing +c + if (slurg(ig) .and. (iswaft.or.isgaft)) then +c +c Terminate slur on single after-grace +c +c ndxslur = igetbits(ipl,4,23) + ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ngs),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +cc Print 11-ndxslur +c Print 24-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten), + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if + slurg(ig) = .false. + listslur = ibclr(listslur,ndxslur) + end if + call addstr('}',1,soutq,lsout) +c +c+++ Try to fix loss of octave with single gaft +c +c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', +c * 13+lnoten,soutq,lsout) + if (isgaft) then + itrans = 0 + do 1 i = 1 , lnotenGA + if (noteqGA(i:i) .eq. chax(39)) then + itrans = itrans+7 + else if (noteqGA(i:i) .eq. chax(96)) then + itrans = itrans-7 + end if +1 continue + if (itrans. eq. -14) then + call addstr(sq//'advance'//sq//'transpose-14',21, + * soutq,lsout) + else if (itrans .eq. -7) then + call addstr(sq//'advance'//sq//'transpose-7',20, + * soutq,lsout) + else if (itrans .eq. 7) then + call addstr(sq//'advance'//sq//'transpose7',19, + * soutq,lsout) + else if (itrans .eq. 14) then + call addstr(sq//'advance'//sq//'transpose14',20, + * soutq,lsout) + end if + end if + else +c +c Multiple grace. Put in literally. Compute beam stuff +c + sumx = 0. + sumy = 0. + sumxy = 0. + sumxx = 0. + sumyy = 0. + x = 0. + do 118 ing = ngs , ngs+nng(ig)-1 + if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac + y = nolevg(ing) + sumx = sumx + x + sumy = sumy + y + sumxy = sumxy + x*y + sumxx = sumxx + x*x + sumyy = sumyy + y*y + x = x+emgfac +118 continue + delta = nng(ig)*sumxx-sumx*sumx + em = (nng(ig)*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*gslfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/gslfac*sumx)/nng(ig) + nolev1 = nint(beta) +c +c Back up +c + notexq = sq//'settiny'//sq//'off{' + if (normsp) then + write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig) + call addstr(notexq(1:18)//'pt}',21,soutq,lsout) + finalshift = ptgr(ig) + else + aftshft = wheadpt*1.33 + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5 + write(notexq(14:17),'(f4.1)')aftshft + call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout) + end if +c +c Start the beam +c + notexq = sq//'ib' + do 119 ing = 2 , mg + notexq = notexq(1:ing+1)//'b' +119 continue + if (upg(ig)) then + notexq = notexq(1:mg+2)//'u' + else + notexq = notexq(1:mg+2)//'l' + end if + notexq = notexq(1:mg+3)//'0' +c +c Get starting note for beam +c + call notefq(noteq,lnoten,nolev1,ncm) + call addstr(notexq(1:mg+4)//noteq(1:lnoten), + * mg+4+lnoten,soutq,lsout) +c +c Put in the slope +c + if (islope .ge. 0) then + call addstr(chax(48+islope),1,soutq,lsout) + else + call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout) + end if +c +c Start a slur on multiple fore-grace +c + if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Need a tweak for postscript slur +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print 11-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten, + * soutq,lsout) + else if (23-ndxslur .lt. 2) then + call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if +c +c Put in tweak for postscript slur +c + if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout) + end if +c +c Put in first note. Call notefq again in case octave changed +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (naccg(ngs) .eq. 0) then + notexq = sq//'zqb0'//noteq(1:lnoten) + lnote = 5+lnoten + else + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten) + lnote = 4+lacc+lnoten + call notefq(noteq,lnoten,nolevg(ngs),ncm) + notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten) + lnote = lnote+5+lnoten + end if + call addstr(notexq,lnote,soutq,lsout) + do 127 ing = ngs+1 , ngs+nng(ig)-1 +c +c Skip +c + ptoff = wheadpt1*emgfac + if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac + if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff + notexq = sq//'off{' + write(notexq(6:8),'(f3.1)')ptoff + if (normsp) finalshift = finalshift-ptoff + call addstr(notexq(1:8)//'pt}',11,soutq,lsout) + if (ing .eq. ngs+nng(ig)-1) then +c +c Terminate beam if needed +c + if (upg(ig)) then + call addstr(sq//'tbu0',5,soutq,lsout) + else + call addstr(sq//'tbl0',5,soutq,lsout) + end if +c +c Terminate after slur if needed +c + if ((isgaft.or.iswaft) .and. slurg(ig)) then +c if (iswaft) ndxslur = igetbits(ipl,4,23) + if (iswaft) ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +c Print 11-ndxslur +cc Print 23-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + end if +c +c Stop slur terminator after exit from this subroutine +c + listslur = ibclr(listslur,ndxslur) + slurg(ig) = .false. + end if + end if +c +c Accidental if needed +c + if (naccg(ing).gt.0) then + call notefq(noteq,lnoten,nolevg(ing),ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ing),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc) + * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if +c +c Put in the (beamed) grace note +c + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten, + * soutq,lsout) +127 continue +c +c Terminate the grace +c +c notexq = sq//'normalnotesize'//sq//'off{' +c lnote = 20 +c notexq = '}'//sq//'off{' +c lnote = 6 + notexq = sq//'off{' + lnote = 5 + ptoff = wheadpt*emgfac + if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17)) + * ptoff = ptoff+wheadpt*accfac + if (isgaft .and. .not.iswaft) then + notexq = notexq(1:5)//'-' + lnote = 6 + ptoff = aftshft + end if + if (normsp) ptoff = finalshift + if (ptoff .lt. 9.95) then + write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff + lnote = lnote+3 + else if (ptoff .lt. 99.95) then + write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff + lnote = lnote+5 + end if + call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout) + if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout) + call addstr(sq//'resetsize',10,soutq,lsout) + end if + return + end + subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip, + * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur, + * ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. +c 12 May 2002 Create this subroutine to isolate postscript slurs/ties. +c Always set \Nosluradjust\Notieadjust +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd, + * settie,fontslur,pstie,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. +c 18 int(ndxslur/16), ditto. So this allows ndxslur>15. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +c +c Bits in isdat4 Only used for linebreak slurs +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +c +c In listslur bit ib is on if slur index ib is in use, ib=0-13. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + pstie = btest(isdat2(isdat),3) .or. idcode.eq.1 + if (btest(isdata,11)) then +c +c Turnon +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then +cc +cc Note was a rest, cannot start slur on rest. +cc +c print* +c call printl('Cannot start slur on a rest') +c call stop1() +c nolevs = ncm+5 +c end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Set level for slur starting on rest +c + if (nolevs.eq.0 .or. nolevs.gt.60) then + if (slurudq .eq. 'u') then + nolevs = ncm+2 + else + nolevs = ncm-2 + end if + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from 12 down +c + ndxslur = log2(16777215-listslur) +c write(*,'()') +c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c write(*,'(10x,B24)')listslur +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff+8 + else + ihoff = ihoff+2 + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + notexq = chax(92) + lnote = 1 +c +c Check for local adjustment default changes +c + if (btest(isdat2(isdat),26)) then + notexq = chax(92)//'sluradjust'//chax(92) + lnote = 12 + else if (btest(isdat2(isdat),27)) then + notexq = chax(92)//'nosluradjust'//chax(92) + lnote = 14 + else if (btest(isdat2(isdat),28)) then + notexq = chax(92)//'tieadjust'//chax(92) + lnote = 11 + else if (btest(isdat2(isdat),29)) then + notexq = chax(92)//'notieadjust'//chax(92) + lnote = 13 + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = notexq(1:lnote)//'islur'//slurudq + lnote = lnote+6 + else + notexq = notexq(1:lnote)//'is'//slurudq + lnote = lnote+3 + end if +c +c Prepend postscript tie switch +c + if (pstie) then + notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote) + lnote = lnote+10 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c +c noteq = notexq +c notexq = chax(92)//'dotted'//noteq + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c +c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + islhgt = nolevs+iupdn+ivoff + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Store height and staff mid level for use with LineBreakTies +c + call setbits(isdat3(isdat),8,14,islhgt) + call setbits(isdat3(isdat),8,22,ncm) +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then +c levson(midchan(iv,kv)) = nolev + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue +c +c Bugfix 070901 for slur ending on rest in 2-voice staff +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then + if (nolevs.le.2 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then +c +c Deal with \curve or \midslur. isdat is ending, j is start. +c + if (btest(isdat3(isdat),0)) then + imid = igetbits(isdat3(isdat),6,2)-32 + else + imid = igetbits(isdat3(j),6,2)-32 + end if +c +c Postscript slurs, and \midslur adjustment is needed. Invoke macro +c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: +c Abs(imid) Postscript slur type +c 1 f +c 2-3 default +c 4 h +c 5 H +c 6+ HH +c + call addstr(chax(92)//'psforts'// + * chax(48+min(abs(imid),6)),9,soutq,lsout) + end if +c +c Shift slur ending for stem on any note? +c + if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff-8 + else + ihoff = ihoff-3 + end if + end if + if (iscrd) then +c +c Shift termination for shifted notehead? +c + if (btest(isdat2(isdat),1)) then +c +c Left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c +c Switch to postscript tie +c + if (pstie) then + notexq = chax(92)//'tieforts'//notexq(1:lnote) + lnote = lnote+9 + end if +c +c Print 13-ndxslur +c 5/25/08 Allow 14 slurs +c + if (23-ndxslur .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + end if + ivoff = ivoff+ivoffinc + end if + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then + if (idcode .eq. is2n1) is1n1=0 + end if + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihoff .ne. 0) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Clear the bit from list of slurs in use +c + listslur = ibclr(listslur,ndxslur) +c +c Zero out the entire strings for start and stop +c + isdata = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + isdat4(isdat) = 0 + isdat1(j) = 0 + isdat2(j) = 0 + isdat3(j) = 0 + isdat4(j) = 0 +c +c Set midi info for slur ending +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then + icm = midchan(iv,kv) + if (slmon(icm)) then + if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then +c +c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. +c + levsoff(icm) = nolevs + settie = .true. + else + levsoff(icm) = 0 + levson(icm) = 0 + slmon(icm) = .false. + end if + end if + end if + end if + isdat1(isdat) = isdata + end if +1 continue +c +c Clear and collapse the slur data list +c + numdrop = 0 + do 2 isdat = 1 , nsdat + if (isdat1(isdat) .eq. 0) then + numdrop = numdrop+1 + else if (numdrop .gt. 0) then + 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 + end if +2 continue + nsdat = nsdat-numdrop +c call report(nsdat,isdat1,isdat2) + return + end + subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv, + * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. (5/26/02) for non-ps slurs only +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove, + * settie,fontslur,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c +c In listslur bit ib is on if slur index ib is in use, ib=0-23. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (btest(islur,1)) then +c +c 't'-slur (idcode=1) somewhere on this note. Find it, check height against +c 's'-slur (idcode=32) +c + sfound = .false. + tfound = .false. + tmove = .false. + do 5 isdat = 1 , nsdat + if (iv .eq. igetbits(isdat1(isdat),5,13) .and. + * ip .eq. igetbits(isdat1(isdat),8,3) .and. + * kv .eq. igetbits(isdat1(isdat),1,12)+1) then + if (.not.tfound) then + tfound = igetbits(isdat1(isdat),7,19).eq.1 + if (tfound) then + nolevt = igetbits(isdat2(isdat),7,19) + isdatt = isdat + if (sfound) go to 6 + end if + end if + if (.not.sfound) then + sfound = igetbits(isdat1(isdat),7,19).eq.32 + if (sfound) then + nolevs = igetbits(isdat2(isdat),7,19) + isdats = isdat + if (tfound) go to 6 + end if + end if + end if +5 continue +c +c Will come thru here if there is a t with no s, so comment out the following +c print*,'Did not find s+t-slurs in doslur' +c +6 continue + if (sfound .and. tfound) + * tmove = nolevs.eq.nolevt .and. +c +c Check if 2 starts or two stops +c + * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or. + * (.not.btest(isdat1(isdats),11).and. + * .not.btest(isdat1(isdatt),11)) ) +c +c This is a flag for later changing slur level, after we know slur dir'n. +c + end if + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + if (btest(isdata,11)) then +c +c Turnon, +c + 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() + end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (idcode.eq.1 .and. tmove) then + iupdn = 1 + if (slurudq .eq. 'd') iupdn = -1 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twenty-fifth slur, one too many!' + write(15,'(/,a)') + * 'You2 defined the twenty-fifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from ? down +c + ndxslur = log2(16777215-listslur) +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) + * ihoff = ihoff+8 + if (btest(isdat2(isdat),3)) then +c +c Tie spacing, (slur start) +c + if (slurudq.eq.'d') then + ivoff = ivoff+1 + ihoff = ihoff+8 + else if (slurudq.eq.'u') then + ivoff = ivoff-1 + if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8 +c +c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') +c + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = chax(92)//'islur'//slurudq + lnote = 7 + else + notexq = chax(92)//'is'//slurudq + lnote = 4 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c + noteq = notexq + notexq = chax(92)//'dotted'//noteq + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. idcode.eq.32) then + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue + if (nolevs.eq.0 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0)) then +c +c Deal with \curve or \midslur +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Remember, only dealing with non-ps slurs +c +c Who knows where the following line came from. Removed it 6/30/02 to +c restore behavior of non-ps slurs to old way +c if (slurudq .eq. 'd') imid = -imid +c 3/8/03 added the following +c + if (slurudq .eq. 'd') imid = -abs(imid) +c + if (btest(isdat3(isdat),1)) then + notexq = chax(92)//'curve' + lnote = 6 + else + notexq = chax(92)//'midslur' + lnote = 8 + end if + if (imid.lt.0 .or. imid.gt.9) then +c +c Need brackets +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (imid .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')imid + lnote = lnote+3 + else if (imid.lt.0 .or. imid.gt.9) then + write(notexq(lnote+1:lnote+2),'(i2)')imid + lnote = lnote+2 + else + write(notexq(lnote+1:lnote+1),'(i1)')imid + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else +c +c 1= 0 . +c Xtups are irrelevant here since they are already all in forced beams. +c Will update itnow by nodur at the END of this loop +c + ip = ip+1 + go to 11 + end if + nreal = nreal+1 + nodue(nreal) = nodur(ivx,ip) + short(nreal) = nodue(nreal).lt.16 .and. + * .not.btest(irest(ivx,ip),0) +c +c Rule out notes that have 'alone'-flag set +c + * .and..not.btest(islur(ivx,ip),18) + ipr(nreal) = ip + itr(nreal) = itnow + if (nodue(nreal) .eq. 1) then +c +c 64th gap +c + if (mod(itnow,2) .eq. 0) then +c +c Start of 32nd gap, lump with following note +c + ip = ip+1 + nodue(nreal) = 1+nodur(ivx,ip) + itnow = itnow+nodue(nreal) + else +c +c End of 32nd gap, lump with preceeding note +c + nreal = nreal-1 + nodue(nreal) = 1+nodue(nreal) + itnow = itnow+1 + end if + else + itnow = itnow+nodur(ivx,ip) + end if + go to 1 +9 continue + ir1 = 1 + itseg = lenbar/ibmrep + do 13 irep = 1 , ibmrep +c +c Set bitmaps for all shorts neighbored by a short. Each bit represents a +c span of 32nd note. maps, mapm, mape record start, full duration, and end +c of consecutive span of beamable (<1/4) notes. +c + maps = 0 + mapm = 0 + mape = 0 + itend = itseg*irep + itoff = itend-itseg + do 2 ir = ir1 , nreal + it2 = itr(ir)+nodue(ir)-2 + if (it2 .ge. itend) then + ir1 = ir + go to 14 + end if +c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal + if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or. + * (ir.lt.nreal.and.short(ir+1)))) then + ib1 = (itr(ir)-itoff)/2 + ib2 = (it2-itoff)/2 + if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or. + * min(ib1,ib2).lt.0) return +c +c Must have an odd number obe beats in a long bar. Auto-beam won't work +c + nip1(ib1) = ipr(ir) + nip2(ib2) = ipr(ir) +c +c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip +c + maps = ibset(maps,ib1) + mape = ibset(mape,ib2) + do 3 ib = ib1 , ib2 + mapm = ibset(mapm,ib) +3 continue + end if +2 continue +14 continue + if (mapm .eq. 0) go to 13 +c +c Zero out bits from forced beams +c + maps = iand(maps,not(mapfb(irep))) + mapm = iand(mapm,not(mapfb(irep))) + mape = iand(mape,not(mapfb(irep))) +c +c Compare map with template. +c + do 4 it = 1 , nummask(ibmtyp) + masknow = mask(it,ibmtyp) + if (iand(masknow,mapm) .eq. masknow) then +c +c Find least significant bit in the mask to check start time +c + mtemp = masknow + maskm = masknow + do 5 is1 = 0 , 47 + if (iand(1,mtemp) .eq. 1) go to 6 + mtemp = ishft(mtemp,-1) +5 continue +6 continue + if (iand(ishft(1,is1),maps) .eq. 0) go to 4 +c +c is1 is the bit where the beam starts. Continue shifting to +c find most significant bit in the mask to check ending time +c + do 7 is2 = is1 , 47 + mtemp = ishft(mtemp,-1) + if (iand(1,not(mtemp)) .eq. 1) go to 8 +7 continue +8 continue +c +c is2 is now the bit on which the beam ends. +c + if (iand(ishft(1,is2),mape) .eq. 0) go to 4 +c +c Did we pick out a single note from the middle of a longer sequence? +c + if (nip1(is1) .eq. nip2(is2)) go to 4 +c +c We almost have a beam. Check equality of notes if needed. +c + if (eqonly(it,ibmtyp)) then + do 10 ip = nip1(is1) , nip2(is2) + if (nodur(ivx,ip) .ne. 8) then +c +c There is a non-1/8th note in this beam. Exit if not 2 quarters +c + if (is2-is1 .ne. 15) go to 4 +c +c Beam is 2 quarters long. Check if can split in half. +c + ithalf = 0 + do 20 iip = nip1(is1) , nip2(is2) + ithalf = ithalf+nodur(ivx,iip) + if (ithalf .gt. 16) go to 4 + if (ithalf .eq. 16) go to 21 +20 continue + print*,'Problem in findbeam, please call Dr. Don' + go to 4 +21 continue +c +c Otherwise, split in half by keeping only the first half. Other half will +c be picked up later, assuming masks are listed longest first. +c + is2 = is1+7 +c +c Reset maskm (since only used part of mask), used later to zero out +c bits that contain beams +c + maskm = 0 + do 15 is = is1 , is2 + maskm = ibset(maskm,is) +15 continue + go to 16 + end if +10 continue + end if +16 continue +c +c This is a beam. If last "effective" ends on odd 64th, add 1 more +c +c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) +c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then + if (abs(amod(to(ipl2(ivx,nip2(is2))) + * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then + nip2(is2) = nip2(is2)+1 + end if + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) + call logbeam(numnew,nip1(is1),nip2(is2)) +c +c Zero out the appropriate bits so these notes don't get used again +c + mapm = iand(mapm,not(maskm)) + if (mapm.eq.0) go to 13 + maps = iand(maps,not(maskm)) + mape = iand(mape,not(maskm)) + end if +4 continue +13 continue + return + end + subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0) + parameter (nkb=3999,maxblks=4000) +c +c Compute an exponent eonk for use in the "flattened" formula for elemskips +c vs time. We must solve the eqution f = 0. Initial quess is eonk0. +c + logical gotclef + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + common /comeon/ eonk,ewmxk + eonk = eonk0 + niter = 0 +1 continue + ewmxk = f1eon(dtmax)**eonk + niter = niter+1 + esum = 0. + desum = 0. + do 2 iptr = nptr1 , nptr2 + targ = durb(iptr)/sqzb(iptr) + esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ) + detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ) + desum = desum+nnpd(iptr)*sqzb(iptr)*detarg +2 continue + f = wovera*feon(dtmin)-xelsk-esum + fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin) + * -desum + if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then + call printl( + * 'Error in findeonk. Please send source to Dr. Don') + eonk = 0. + ewmxk = 1. + return + end if + dsoln = -f/fp + if (abs(dsoln) .lt. .1*tol) return +c +c Not converged yet, try again +c + eonk = eonk+dsoln + go to 1 + end + function fnote(nodur,ivx,ip,nacc) +c +c This return the real duration of a note +c + parameter (nm=24) + integer*4 nodur(nm,200),nacc(nm,200) + logical btest + ipback = ip + if (nodur(ivx,ip) .gt. 0) then + if (ip .gt. 1) then +c +c Check if this is last note of xtup +c + if (nodur(ivx,ip-1).eq.0) then + ipback = ip-1 + go to 2 + end if + end if + fnote = nodur(ivx,ip) + return + end if +2 continue +c +c Count back to prior non zero note. Start at ip to avoid neg index if ip=1. +c Count how many doubled xtups notes there are from ip-1 to first note. +c + ndoub = 0 + do 1 ip1m1 = ipback , 1 , -1 + if (nodur(ivx,ip1m1) .gt. 0) go to 4 + if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1 +1 continue +4 continue +c +c count forward to next non-0 nodur. Start at ip in case last note of xtup. +c + do 3 iip = ip , 200 +c +c Count doubled xtup notes from ip to end. +c + if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1 + if (nodur(ivx,iip) .gt. 0) then +c fnote = nodur(ivx,iip)/float(iip-ip1m1) + fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub) + if (btest(nacc(ivx,ip),18)) then + fnote = 2*fnote + else if (btest(nacc(ivx,ip),27)) then + fnote = 1.5*fnote + else if (ip .gt. 1) then + if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote + end if + return + end if +3 continue + print*,' ' + call printl + * ('Probable misplaced barline or incorrect meter, stopping') +c call printl('Program error in fnote, send source to Dr. Don') + call stop1() + end + subroutine g1etchar(lineq,iccount,charq) + parameter(nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,issegno,isheadr,isvolt,fbon + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + character*1 charq + character*128 lineq,lnholdq +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not.endmac) then + iccount = 0 + if (.not.mplay) nline = nline+1 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return + end + subroutine g1etnote(loop,ifig,optimize,fulltrans) + parameter (nm=24,nkb=3999,mv=24576,maxblks=4000) + character*1 chax + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend, + * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt, + * stickyS + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + logical mrecord,mplay,endmac,shifton,gotclef,optimize + character*128 lineq,lnholdq + character*1 charq,dotq,dumq,durq,charlq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical novshrinktop,upslur,fontslur,ztrans, + * WrotePsslurDefaults,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + character*51 literq(3) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + common /comsize/ isize(nm) + data literq + * /'Literal TeX string cannot start with 4 backslashes!', + * 'TeX string must have <129 char, end with backslash!', + * 'Type 2 or 3 TeX string can only start in column 1!'/ + cdot = .false. +1 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') charlq = charq + if (lastchar) then + if (index('/%',charlq) .eq. 0) then + print* + print*,'WARNING:' + print*,'Last non-blank character is "',charlq,'", not "/,%"' + print*,'ASCII code:',ichar(charlq) + write(15,'(/a)')'Last non-blank character is "'//charlq// + * '", not "/,%"' + write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq) +c +c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. +c + ilbuf = ilbuf-1 + lbuf(ilbuf) = lbuf(ilbuf)+2 + bufq = bufq(1:ipbuf)//' /' + write(15,*)'appending /' + print*,'appending /' + lineq = lineq(1:iccount)//' /' + lastchar = .false. + go to 1 + end if + return + end if + if (charq .eq. ' ') then + go to 1 + else if (charq.eq.'%' .and. iccount.eq.1) then + iccount = 128 + go to 1 +c +c Replacement 1/22/12 since gfortran 4.7 with -O was choking here! +c +c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + else if (index('abcdefg',charq).gt.0 .or. + * charq.eq.'r') then +c +c This is a note/rest. gotclef is only used for checking for clef before "/" +c + if (cdot) go to 28 + if (gotclef) gotclef=.false. + idotform = 0 + numnum = 0 + plusmin = .false. +28 nnl(ivx) = nnl(ivx)+1 + if (nnl(ivx) .gt. 200) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>200 notes in line of music. Use smaller blocks!') + call stop1() + end if + dotq = 'x' +c +c Check if this is 'r ' and previous note was full-bar-pause +c + fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and. + * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar +2 call g1etchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + if (charq .eq. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one digit allowed after rest symbol "r"!') + call stop1() + end if + numnum = 2 + if (plusmin) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>2 digits in note symbol!') + call stop1() + end if + else if (durq.eq.'d') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then + iddot = 1 + iccount = iccount+1 +c +c Since we flow out, double dots won't work with other dot options +c + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, provided a number follows. +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then +c +c Backup, exit the loop normally +c + iccount = iccount-2 + go to 2 + end if + call readnum(lineq,iccount,dumq,fnum) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after 2nd +/- (shift dot)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + iccount = iccount-1 + end if + go to 2 + else if (index('<>',durq) .gt. 0) then +c +c Accidental shift +c +c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, +c * 'Expected "f", "s", or "n" before "<" or ">"!') + * 'Expected "f", "s", "n" or "A" before "<" or ">"!') + call stop1() + end if + ipm = 1 + if (durq .eq. '<') ipm=-1 + call g1etchar(lineq,iccount,durq) + if (index('123456789.0',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after (accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horizontal accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else if (index('+-',durq) .gt. 0) then + if (charq .ne. 'r') then + if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then + ipm = 1 + if (durq .eq. '-') ipm=-1 + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .gt.0) then +c +c This may be start of accidental shift, but may be octave jump; then duration +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .gt. 0) then +c +c This is an accid shift since there's a 2nd consecutive signed number. +c Check size of 1st number. +c + if (fnum .gt. 30.5) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Vertical accidental shift must be less than 31!') + call stop1() + end if + ipm = 1 + if (durq .eq. '-') ipm = -1 + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected 2nd number of accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horiz. accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else +c +c Not accid shift, reset, then flow out +c + iccount = icsav + end if + end if + end if + plusmin = .true. + if (numnum .eq. 2) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 +c +c It's a rest containing +|- . Must refer to a vertical shift. Read past. +c + else + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,dum) + iccount = iccount-1 + go to 2 + end if +c else if (index('ulare',durq) .gt. 0) then + else if (index('ularec',durq) .gt. 0) then + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change +c + call g1etchar(lineq,iccount,durq) + if (index('.0123456789:',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a number or colon here!') + call stop1() + end if + if (durq .eq. ':') then + if (.not.stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned off sticky stemshrinks without turning on!') + call stop1() + end if + stickyS = .false. + go to 2 + end if + call readnum(lineq,iccount,durq,dum) + if (dum.lt..5 .or. dum.gt.4.) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Stemlength shortening must be from .5 to 4!') + call stop1() + end if + if (durq .ne. ':') then + iccount = iccount-1 + else + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on sticky stemshrinks when already on!') + call stop1() + end if + stickyS = .true. + end if + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 2 + else if (durq .eq. 'p') then + fulbrp = charq.eq.'r' + if (.not. fulbrp) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'The option "p" only works with "r" (rest)!') + call stop1() + end if + go to 2 + else if (durq .eq. 'b') then + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "b"; I expected "rb"!') + call stop1() + else if (numnum .eq. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "r" & "b" with two numbers!') + end if + go to 2 + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'First char after "x" in xtuplet must be "1"-"9"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (fnum .gt. 99) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Xtuplet cannot have more than 99 notes!') + call stop1() + else if (index(' DFnd',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only legal characters here are " ","D","F","n"!') + call stop1() + end if +c +c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. +c + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here, number already set, but may also +c have used this before number was set. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = 1 + call g1etchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call g1etchar(lineq,iccount,durq) + end if + if (durq .eq. 'n') then +c +c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. +c + numshft = 0 +30 call g1etchar(lineq,iccount,durq) + if (durq .eq. 'f') then + go to 30 + else if (index('+-',durq) .gt. 0) then + numshft = numshft+1 + if (numshft .eq. 3) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only 2 shifts are allowed after "n" in xtup!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit or "."!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if ((numshft.eq.1 .and. snum.gt.15.1) .or. + * (numshft.eq.2 .and. snum.gt.1.51)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Shift number after "n" in xtup is out of range!') + call stop1() + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope alteration for bracket +c + call getchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'For slope adjustment, this character must be "+" or "-"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if (nint(snum) .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slope adjustment cannot exceed 15!') + call stop1() + end if + go to 30 + else if (index('123456789',durq) .gt. 0) then +c +c Unsigned integer => alternate printed number +c + call readnum(lineq,iccount,durq,snum) + if (snum .gt. 15.1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Alternate xtup number after "n" must be <16!') + call stop1() + end if + iccount = iccount-1 + go to 30 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "n" in xtup!') + call stop1() + end if + end if + ntup = nint(fnum) + do 6 itup = 2 , ntup + nodur(ivx,nnl(ivx)) = 0 + nnl(ivx) = nnl(ivx)+1 +110 call g1etchar(lineq,iccount,durq) + if (durq.eq.' ') then + go to 110 + else if (durq .eq. 'o') then +c +c Ornament in xtup. "o" symbol must come AFTER the affected note +c + call g1etchar(lineq,iccount,dumq) + if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then + if (index('fg',dumq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Fermata or segno not allowed in xtuplet!') + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + end if + call stop1() + end if + if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +29 call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') go to 29 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1, + * ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if + go to 110 + else if (index('st(){}',durq) .gt. 0) then +c +c Slur in xtup +c + iposn = 0 + numint = 0 +15 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (index('udlbfnht',dumq) .gt. 0) then + if (dumq.eq.'t' .and. durq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + go to 15 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum).gt.6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in the range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 40 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount, + * ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +40 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 15 + + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 15 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') + * iccount=iccount+1 + go to 15 + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + go to 15 + else if (dumq .ne. ' ') then + ic = ichar(dumq) + if ((ic.ge.48.and.ic.le.57) .or. + * (ic.ge.65.and.ic.le.90)) then + if (iposn .eq. 1) then + if (durq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + go to 15 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be 2nd character in slur symbol!') + call stop1() + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + end if + go to 110 + else if (index('0123456789#-nx_',durq) .gt. 0) then +c +c We have a figure. Only allow on 1st note of xtup +c + if (itup .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Figure in xtup only allowed on 1st note!') + call stop1() + else if (durq.eq.'x') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'No floating figures in xtuplets!') + call stop1() + end if + if (usefig .and. ivx.eq.1) ifig = 1 +26 call g1etchar(lineq,iccount,durq) + if (index('0123456789#-n_.:',durq) .gt. 0) then + go to 26 + else if (durq .eq. 's') then + isligfont = .true. + go to 26 + else if (durq .eq. '+') then +c +c vertical offset, must be integer then blank +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .ne. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 26 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure in xtuplet!') + call stop1() + end if + go to 110 + else if (durq .eq. 'G') then + ngr = 1 +79 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 79 + else if (index('AWulxs',charq) .gt. 0) then + go to 79 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 79 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 79 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 71 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +75 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 75 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +78 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 78 + else if (index('+-nfs',charq) .gt. 0) then + go to 78 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +71 continue + go to 110 + else if (durq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + go to 110 + else if (durq .eq. 'M') then +c +c Temporary trap until I get around putting this in pmxb +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macros not yet allowed in xtuplets!') + call stop1() + else if (durq .eq. 'X') then + call g1etx(lineq,iccount,.false.,shifton, + * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt) + go to 110 + else if (durq .eq. 'z') then +c +c Chord note in xtup. Read past for now. +c +33 call g1etchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 33 + go to 110 + else if (durq .eq. 'D') then +c +c Dynamic mark +c + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + go to 110 + else if (durq .eq. '%') then + if (iccount .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Comment must have "%" in column 1!') + call stop1() + end if + iccount = 128 + go to 110 + else if (durq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + go to 110 + end if + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 110 +c+++ + else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'[' + * .and. lineq(iccount+2:iccount+2).eq.' ') then + iccount = iccount+2 + go to 110 +c+++ + end if +c +c End of xtup options. At this point symbol can only be note or rest +c + if (index('abcdefgr',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In xtup, this character is not allowed!') + call stop1() + else if (durq.eq.'r' .and. itup.eq.ntup) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, PMX cannot end an xtuplet with a rest!') + call stop1() + end if +7 call g1etchar(lineq,iccount,durq) + if (index('2345678ulcb',durq) .gt. 0) then + go to 7 + else if (index('sfn',durq) .gt. 0) then +c +c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 7 + else if (index('+-<>',durq) .gt. 0) then +c +c May have either octave jump or shifted accid. on main xtup note +c + if (index('+-',durq).gt.0 .and. + * index('01234567890',lineq(iccount+1:iccount+1)).eq.0) + * go to 7 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 7 + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = ndoub+1 + go to 7 + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + go to 7 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal option on xtuplet note!') + call stop1() + end if + if (itup .eq. ntup-ndoub) go to 3 +6 continue +3 continue +c +c 6==End of loop for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c + if (mod(itsofar(iv),lenbar) .ne. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest must start at beginning of bar!') + call stop1() + else if (iv.eq.1.and.ibarmbr.gt.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest only OK at one time per block!') + call stop1() + end if +c +c For some purposes, pretend its one bar only +c + nodur(iv,nnl(iv)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 +c20 call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer after "rm"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mbrest = nint(fnum) + iccount = iccount-1 +c if (ichar(durq).ge.48.and.ichar(durq).le.57) then +c mbrest = 10*mbrest+ichar(durq)-48 +c go to 20 +c end if + if (nv .gt. 1) then + if (iv .eq. 1) then + mbrestsav = mbrest + else + if (mbrest .ne. mbrestsav) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must enter same multi-bar rest in every voice!') + call stop1() + end if + end if +c +c Zero out mbrestsav so can check at end of input block whether +c all voices have one +c + if (iv .eq. nv) mbrestsav=0 + end if + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "rm"!') + call stop1() + end if + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. ',') then + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (index('oL',durq) .gt. 0) then +c +c Suppress full bar rest, or look left for height +c + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o","L" options only legal for rest, not note!') + call stop1() + end if + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" or "F" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'A') then +c +c Main note accidental option +c + call getchar(lineq,iccount,durq) + if (index('o+-<>',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o",+","-","<",">" are the only legal options here!') + call stop1() + end if +c +c Need more stuff here +c + if (durq .ne. "o") then +c +c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will +c proceed to number input checking +c + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character!') + print*,'ASCII code:',ichar(durq) + call stop1() + end if +c +c End of block for note options. +c +c Set the duration +c + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) +c +c Check for double dot +c + if (iddot .eq. 1) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + iddot = 0 + end if + else if (fulbrp) then + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + fulbrp = .false. + end if + rest(ivx,nnl(ivx)) = charq.eq.'r' +c +c If inside forced beam, check if note is beamable +c + if (fbon) then + if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120 + if (nnl(ivx) .gt. 1) then + if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unbeamable thing in forced beam!') + call stop1() + end if +120 continue +c +c Get number of prior bars for later check on whether note spans bar line +c + nbb4 = itsofar(ivx)/lenbar + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (mod(itsofar(ivx),lenbar) .eq. 0) then + nbars = nbars+1 + if (shifton) barend = .true. +c +c Will check barend when 1st note of next bar is entered. +c + if (nbars .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot have more than 15 bars in an input block!') + call stop1() + end if + nib(ivx,nbars) = nnl(ivx) + if (firstline .and. lenbar.ne.lenbr1) then +c +c Just finished the pickup bar for this voice. +c + if (itsofar(ivx) .ne. lenbr0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Pickup bar length disagrees with mtrnum0!') + call stop1() + end if + lenbar = lenbr1 + itsofar(ivx) = 0 + end if + else if (barend) then + if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + barend = .false. + else if (itsofar(ivx)/lenbar .gt. nbb4) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'This note spans a bar line!') + call stop1() + end if + if (idotform.eq.1 .or. idotform.eq.3) then + call g1etchar(lineq,iccount,charq) + if (index('abcedfgr',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected note name or "r" here!') + call stop1() + end if + idotform = idotform+1 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then + call g1etchar(lineq,iccount,charq) + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected chord note name here!') + call stop1() + end if +25 call g1etchar(lineq,iccount,durq) +c if (index('dre12345678',durq) .gt. 0) then + if (index('dre12345678c',durq) .gt. 0) then + go to 25 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 25 + else if (durq .eq. 'A') then + if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n" before "A" in chord note!') + call stop1() + end if + go to 25 + else if (index('<>',durq) .gt. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then +c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n,A" before "<" or ">"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here for accidental shift!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (index('+-',durq) .gt. 0) then + if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0) + * go to 25 +c +c Number or '.' (durq) follows +/- . Get it. +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.' .and. index('1234567890', + * lineq(iccount+1:iccount+1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"." here must be followed by a digit!') + call stop1() + else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Number after +/- must follow "d,s,f,n,A"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .eq. 0) then + iccount = iccount-1 + go to 25 + end if +c +c 2nd +/- +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.') call g1etchar(lineq,iccount,durq) + if (index('1234567890',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in chord note!') + call stop1() + end if + else if (charq .eq. 'G') then + ngr = 1 +9 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 9 + else if (index('AWulxs',charq) .gt. 0) then + go to 9 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 9 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 9 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 19 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +55 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 55 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +18 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 18 +c else if (index('nfs',charq) .gt. 0) then + else if (index('+-nfs',charq) .gt. 0) then + go to 18 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +19 continue + else if (charq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. "o" symbol must come AFTER the affected note +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o" must be in same input block, after affected note!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + call stop1() + end if + if (dumq .eq. ':') then + call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after "o:"!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else if (dumq .eq. 'g') then + if (issegno) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, only one "segno" per input block!') + call stop1() + else if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'segno can only be in voice 1!') + call stop1() + end if + issegno = .true. +12 call g1etchar(lineq,iccount,dumq) + if (dumq.eq.'-' .or. + * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12 + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in segno ornament symbol!') + call stop1() + end if + else if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +22 call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after ":"!') + call stop1() + end if + go to 32 + else if (dumq .ne. ' ') then + go to 22 + end if + else if (dumq .eq. 'f') then + call g1etchar(lineq,iccount,dumq) + if (index(' d+-:',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "f" in fermata ornament symbol!') + call stop1() + end if + if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') go to 32 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if +32 continue + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + else if (index('st(){}',charq) .gt. 0) then + numint = 0 + iposn = 0 +8 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (charq.eq.'t' .and. dumq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + if (index('udltb+-fnhHps ',dumq) .eq. 0) then +c +c Check for explicit ID code. +c + ic = ichar(dumq) + if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or. + * ic.gt.90) then +c +c Not 0-9 or A-Z, so exit +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + else +c +c It is a possible ID code. Right place? +c + if (iposn .ne. 1) then +c +c Slur ID is not 2nd! +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be second character in slur symbol!') + call stop1() + else if (charq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + end if +c +c Slur ID is OK. Note it cannot be "H" at this point.. +c + go to 8 + else if (dumq .eq. 'H') then + if (iposn .eq. 1) go to 8 +c +c "H" is NOT an ID code. +c + if (.not.fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + end if + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount=iccount+1 + iposn = iposn+1 + end if + go to 8 + else if (index('fh',dumq).gt.0 .and. .not.fontslur + * .and. charq.eq.'t') then +c +c 3/9/03 Can't reshape postscript tie. +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + iposn = iposn+2 + go to 8 + end if + if (index('udltbfnh',dumq) .gt. 0) then + go to 8 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + if (fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+|-" for slur height only allowed in "s"-slurs!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 41 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +41 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1 + go to 8 + end if + else if (charq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"!') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + end if + else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or. + * index('#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + if (itsofar(ivx).eq.0 .and. + * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then +c +c Figure before first note in block +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot put figure before first note in block!') + call stop1() + end if + if (charq.eq.'x') then + indxb = index(lineq(iccount:128),' ') + if (indxb .lt. 5) then + call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot have a blank here in floating figure!') + call stop1() + end if + end if + if (usefig) ifig = 1 +5 call g1etchar(lineq,iccount,charq) + if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure!') + call stop1() + else if (charq .eq. '+') then +c +c vertical offset, must be integer, then blank +c + call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,charq,fnum) + if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 5 + else if (charq .eq. 's') then + isligfont = .true. + end if + if (charq .ne. ' ') go to 5 + else if (charq .eq. '[') then + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Started forced beam while another was open!') + call stop1() + end if + fbon = .true. +17 call g1etchar(lineq,iccount,charq) + if (index('uljhf:',charq) .gt. 0) then + go to 17 + else if (index('+-',charq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 17 + else if (charq .eq. 'm') then +c +c Forced multiplicity, next char should be 1-4 +c + call g1etchar(lineq,iccount,charq) + if (index('1234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!') + call stop1() + end if + go to 17 + else if (charq .ne. ' ') then + if (index('0123456789',charq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "[", digits must now be preceeded by "+" or "-"!') + print*,'You will have to edit older sources to meet this rqmt,' + print*,'but it was needed to allow 2-digit height adjustments.' + print*,'Sorry for the inconvenience. --The Management' + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after [!') + end if + call stop1() + end if + else if (charq .eq. ']') then + if (.not.fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced beam stop with no corresponding start!') + call stop1() + end if + call g1etchar(lineq,iccount,charq) + if (charq .eq. '-') then + if (lineq(iccount+1:iccount+2) .ne. '[ ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'Only sequence allowed here is "[ "!') + call stop1() + else + iccount = iccount+2 + end if + else if (charq .eq. '[') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else +c +c Forced beam is really ending +c + fbon = .false. + if (charq .eq. 'j') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"]" must be followed by blank, "j", "-", or "["!') + call stop1() + end if + end if + else if (charq .eq. 'D') then +c +c Dynamic mark +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"D" must not come before any notes have been entered!') + call stop1() + end if + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + else if (index('lhw',charq) .gt. 0) then +c +c Save position for later check +c + icclhw = iccount + call g1etchar(lineq,iccount,durq) + if (index('0123456789.+- ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "l", "w", or "h"!') + call stop1() + end if + isheadr = isheadr .or. charq .eq. 'h' + if (index(' +-',durq) .gt. 0) then +c +c There is a header (or lower string?) +c + if (index('+-',durq) .gt. 0) then +c +c User-defined vert offset (\internote). +c + if (charq .ne. 'h') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+" or "-" not permitted here!') + call stop1() + end if +c +c Have "h" followed by +/- . Check for digit. +c Can blow durq since not using fnum for now, but... +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a digit here!') + call stop1() + end if +c +c Have "h" followed by +/- followed by a digit. No need to get the number. +c +c call readnum(lineq,iccount,durq,fnum) + end if + if (charq .ne. 'w') then +c +c Header or lower string. +c + if (icclhw .ne. 1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"h" or "l" must be first character in line!') + call stop1() + end if +c +c Read past the next line, which has the string. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol "w" (width) must be followed by a digit!') + call stop1() + end if + else +c +c Height or width change spec. Check if at start of piece. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol must go at top of first input block!') + call stop1() + end if + call readnum(lineq,iccount,durq,dimen) +c +c Check units. Convert to points +c + if (durq .eq. ' ' .or. durq .eq. 'p') then + dimen = dimen+.5 + else if (durq .eq. 'i') then + dimen = dimen*72+.5 + else if (durq .eq. 'm') then + dimen = dimen/25.4*72+.5 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal unit; must be "p","i",or"m"!') + call stop1() + end if + if (charq .eq. 'h') then + ptheight = int(dimen) + else + widthpt = int(dimen) + end if + end if + else if (charq .eq. 'm') then +c +c Time signature change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Meter change only OK in voice 1, at start of block!') + print*,'voice number is',ivx + call stop1() + end if + newmeter = .true. + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + if (mtrnuml .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Digit 0 not allowed here!') + call stop1() +c else if (mtrdenl .eq. 1) then +cc +cc Kluge!!! +cc +c mtrdenl = 2 +c mtrnuml = 2*mtrnuml + end if + call readmeter(lineq,iccount,mtrnmp,mtrdnp) +c +c Read past printed time signature; not used in pmxa. +c + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnuml*lenbeat + mtrnuml = 0 + else if (charq .eq. 'C') then + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. +c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') + * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!') + call stop1() + end if + gotclef = .true. + else if (charq .eq. 'R') then + if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Repeats can only go in voice 1!') + call stop1() + end if +10 call g1etchar(lineq,iccount,durq) + if (index('lrdDbz',durq) .gt. 0) go to 10 + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "R" (repeat/double bar)!') + call stop1() + end if + else if (charq .eq. 'V') then +c +c Ending +c + if (iv .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Voltas are only allowed in voice #1!') + call stop1() + else if (isvolt) then + print* + print*,'*******WARNING********' + write(15,'(/,a)')'*******WARNING********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There is more than one volta in this input block.!') + print*,'This may work in a score, but WILL NOT work in parts.' + print*, + *'Safest to have only 1 volta per block, at the start of the block' + write(15,'(a)') + * 'This may work in a score, but WILL NOT work in parts.' + write(15,'(a)') + *'Safest to have only 1 volta per block, at the start of the block' + end if + isvolt = .true. + lvoltxt = 0 +11 call g1etchar(lineq,iccount,durq) + if (durq .ne.' ') then + go to 11 + end if + else if (charq .eq. 'B') then + continue + else if (charq .eq. 'P') then + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only allowed at beginning of block!') + call stop1() + end if +16 call g1etchar(lineq,iccount,durq) + if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and. + * ichar(durq).le.57)) go to 16 + if (durq .eq. 'c') then +c +c Expect a centered name, and it has to be last option +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '"') then +c +c Quoted name, go to next quote mark +c + do 35 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. '"') go to 36 +35 continue + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Missing close quote after page number command (P)!') + call stop1() +36 continue + else if (durq .ne. ' ') then +c +c Space-delimited name, look for next blank +c + do 37 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. ' ') go to 38 +37 continue +38 continue + end if + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l","r","c" or digit allowed after "P"!') + call stop1() + end if + else if (charq .eq. 'W') then + call g1etchar(lineq,iccount,durq) + if (index('.0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here!') + call stop1() + end if + call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1)) + else if (charq .eq. 'T') then +c +c Titles +c + call g1etchar(lineq,iccount,durq) + if (index('itc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must put "i", "t", or "c" after "T"!') + call stop1() + end if + ihead = ihead+2**(index('itc',durq)-1) +c +c Maybe a number after 'Tt', but ignore here. Read past string on next line. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else if (charq .eq. 'A') then +27 call g1etchar(lineq,iccount,durq) + if (index('rbsdeK',durq) .gt. 0) then + go to 27 + else if (durq .eq. 'v') then + if (ibarcnt .eq. 0) novshrinktop = .true. + go to 27 + else if (durq .eq. 'a') then + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fbar) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'i') then + call g1etchar(lineq,iccount,durq) +c +c Local interstaff correction. Set to -1. if not specifiec, or after use, +c or anytime except at top, since pmxb handles all times except at top. +c + call readnum(lineq,iccount,durq,tintstf) + if (ibarcnt .eq. 0) fintstf = tintstf + iccount = iccount-1 + go to 27 + else if (durq .eq. 'I') then +c +c Global interstaff correction. Use in place of fintstf if fintstf<0 +c + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'o') then + optimize = .true. + go to 27 + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call g1etchar(lineq,iccount,durq) + if (index('-0st',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "AS", need nv instances of "s,t,-,0"!') + call stop1() + end if + if (durq.eq.'-'.or.durq.eq.'s') then + isize(iiv) = 1 + else if (durq.eq.'t') then + isize(iiv) = 2 + end if +50 continue + go to 27 + else if (durq .eq. 'p') then + fontslur = .false. +42 continue + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,durq) + if (index('shtc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only letters allowed here are "s","h","t","c"!') + call stop1() + end if +c +c Now check for another default modifier +c + go to 42 + else if (index('lh',durq) .gt. 0) then +c +c Flags for optional linebreak ties or header specials +c + go to 42 + else + iccount = iccount-1 + end if + go to 27 + else if (durq .eq. 'N') then +c +c Override default name for a part file. Must have part number, then +c partname in quotes. Must be on line by itself, and start in column 1. +c Will only be passed thru to scor2prt. +c + if (iccount .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must start in column 1!') + call stop1() + end if + ndxquote = index(lineq,'"') + if (ndxquote.lt.4 .or. ndxquote.gt.5 .or. + * index('123456789',lineq(3:3)).eq.0 .or. + * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must be followed by inst. #, then quote!') + call stop1() + end if + ndxquote = index(lineq(ndxquote+1:128),'"') + if (ndxquote .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In "AN", file name must be in quotes!') + call stop1() + end if + iccount = 128 + else if (durq .eq. 'T') then + cstuplet = .true. + else if (durq .eq. 'R') then +c +c Get full name of normal include file; must occupy remainder of line +c + call getpmxmod(.false.,lineq(iccount+1:128)) + iccount = 128 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'After "A" must follow one of the letters abdeiINprsST!') + * 'After "A" must follow one of the letters abdeiINprRsST!') + call stop1() + end if + else if (charq .eq. 'K') then +c +c Rules and function of K command +c +c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is +c initial sig, and must be passed to pmxb because it is needed when topfile +c is called, which is before the K+n+m command is read in pmxb. Also, we +c compute and save ibrkch and newkey for each syst, accounting for key changes, +c then adjust fbar to make poenom much more accurate. +c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. +c + call g1etchar(lineq,iccount,durq) + if (index('+-i',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"K" (transpose or key change) must be followed by "+,-,i"!') + call stop1() + end if + if (durq .ne. 'i') then +c +c Normal key change and/or transposition) +c +c iccount = iccount+1 + num1 = 44-ichar(durq) +c +c num1= +1 or -1 +c + ztrans = num1.eq.-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st +/- must be followed by a number!') + call stop1() + end if +c iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = nint(fnum)*num1 + ztrans = ztrans .and. num1.eq.0 + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st number after "K" must be followed by "+,-"!') + call stop1() + end if + iccount = iccount+1 + num2 = 44-ichar(durq) + call readnum(lineq,iccount,durq,fnum) + num2 = num2*int(fnum+.1) + if (num1.eq.0 .and. .not.ztrans) then +c +c Key change, only one per block allowed +c + if (iskchb) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one key change allowed per input block!') + call stop1() + end if + iskchb = .true. + nkeys = nkeys+1 + kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0 +c +c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. +c + ibrkch(nkeys) = ibarcnt+nbars + if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1 + newkey(nkeys) = num2+idsig + else +c +c Transposition +c + fulltrans = .true. + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Transposition must be at top of first input block!') + call stop1() + end if + isig1 = num2 + idsig = isig1-newkey(1) +c +c idsig is the difference between sig after transposition, and sig in setup. +c It may alter # of accid's in key changes if there is transposition. +c + end if + else ! durq='i' +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; +c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c if (fulltrans) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot yet combine full and instrument transposition!') +c call stop1() +c end if + call GetiTransInfo(.true.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '|') then +c +c Optional bar symbol +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar line marker out of place!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + else if (charq .eq. '/') then + if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with repeated ornament still on!') + ornrpt = .false. + end if + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with sticky stemshrink still on!') + stickyS = .false. + end if + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block ended with forced beam open!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + else if (gotclef) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not enter clef at end of input block!') + call stop1() + end if + barend = .false. +c +c Perform time checks +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not divisible by lenbar!') + print*,'lenbar is ',lenbar + call stop1() + else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then + print* + print*,'# of bars in voice 1, current voice:', + * itsofar(1)/lenbar,itsofar(ivx)/lenbar + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not equal to voice 1!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new voice +c + if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0 + nbars = 0 + if (durq .eq. ' ') then +c +c New voice is on next staff +c + iv = iv+1 + ivx = iv + else +c +c New voice is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + if (ivx .gt. nm) then + write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm, + * ' lines of music at once' + call stop1() + end if + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + do 24 j = 1 , 200 + rest(ivx,j) = .false. + nacc(ivx,j) = 0 +24 continue +c +c For midi stuff, record that there is a 2nd line of music in this voice +c + if (ismidi) twoline(iv) = .true. + end if + end if + iccount = 128 + else if (charq .eq. 'S') then +c +c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"S" can only be in first input block!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit must follow "S"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + nsyst = nint(fnsyst) +14 continue + if (durq .eq. 'P') then +c +c New npages for parts. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + npages = nint(fnsyst) + go to 14 + else if (durq .eq. 'm') then +c +c Reset musize (musicsize). +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + musize = nint(fnsyst) + wheadpt = whead20*musize + go to 14 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in "S" symbol!') + call stop1() + end if + else if (charq .eq. 'L') then + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+nbars+1 + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced line break!') + call stop1() + end if + call readnum(lineq,iccount,durq,sysflb) + isysflb(nflb) = nint(sysflb) + if (nflb .gt. 1) then +c +c Check if new number is > prior one +c + if (isysflb(nflb) .le. isysflb(nflb-1)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You already forced a line break at a later line!') + call stop1() + end if + end if + if (npages .eq. 0) then + print* + print*,'WARNING! You forced a line break at line ', + * isysflb(nflb),' but npage = 0. Continue?' + read(*,'(a)') charq + if (index('yY',charq) .eq. 0) call stop1() + else if (isysflb(nflb) .gt. nsyst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced line break at line num > nsyst!') + call stop1() + else if (index(' PM',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have " ", "P", or "M" here!') + call stop1() + end if + if (durq .eq. 'P') then +c +c Forced page break here, get page number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced page break!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + nfpb = nfpb+1 + ipagfpb(nfpb) = nint(fnum) + isysfpb(nfpb) = isysflb(nflb) + if (ipagfpb(nfpb) .gt. npages) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break at page num > npages!') + call stop1() + else if (nfpb .gt. 1) then + if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break numbers must increase!') + call stop1() + end if + end if + end if + if (index(' M',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in linebreak symbol!') + call stop1() + else if (durq .eq. 'M') then + nmovbrk = nmovbrk+1 + isysmb(nmovbrk) = isysflb(nflb) + call g1etchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Vertical spacing, read past number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer required here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + go to 31 + else if (durq .eq. 'i') then +c +c Change indentation, +c + call g1etchar(lineq,iccount,durq) + if (index('.123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Decimal number required here!') + call stop1() + end if +c +c fracsys was initialized in block data to all 0.'s +c + call readnum(lineq,iccount,durq,fracsys(nmovbrk)) + go to 31 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have "+" or "-" after "r" as movement break option!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iorig in original list of instruments. +c + nv = 0 + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number, get next two characters +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')ninow + else +c +c durq is a single digit number for noinow +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq// + * ' at movement break!') + call stop1() + end if + ninow = ichar(durq)-48 + end if + if (ninow.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New number of instruments must be <= original!') + call stop1() + end if + do 63 iinow = 1 , ninow + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal 2-digit instrument number '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')iorig + else +c +c durq is a single digit number for iorig +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal instrument number '//durq// + * ' at movement break!') + call stop1() + end if + iorig = ichar(durq)-48 + end if + if (iorig .gt. noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New instrument number must be <= original noinst!') + call stop1() + end if + nv = nv+nsperi(iorig) +63 continue + do 61 iiv = 1 , nv +c +c Get clef names +c + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!') + call stop1() + end if +c +c Initialize new voices +c + nvmx(iiv) = 1 + ivmx(iiv,1) = iiv + itsofar(iiv) = 0 + nnl(iiv) = 0 + do 62 j = 1 , 200 + rest(iiv,j) = .false. +62 continue +61 continue +c +c Loop back up, this might not be last option in M +c + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after Movement break symbol!') + call stop1() + end if + if (fracsys(nmovbrk) .lt. 0.001) then +c +c Since fracsys was not explicitly set, set it to prior value. +c + if (nmovbrk .eq. 1) then + fracsys(nmovbrk) = fracindent + else + fracsys(nmovbrk) = fracsys(nmovbrk-1) + end if + end if + end if +c +c Just before exiting if-block for forced line breaks, set counter to use when +c dealing with vertical space calcs +c + nistaff(nflb) = nv-1 + else if (charq .eq. 'F') then + usefig = .false. + else if (charq .eq. 'X') then + call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1, + * udsp(ibarcnt+nbars+1),wheadpt) + else if (charq .eq. 'I') then +c +c MIDI settings. +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MIDI stuff only allowed at start of block!') + call stop1() + end if + if (nv .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry but MIDI does not work with more than 15 voices!') + call stop1() + end if + ismidi = .true. + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.true.) + else if (charq .eq. 'M') then + call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx, + * nline) + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + else + print*,'ASCII code:',ichar(charq) + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character is not allowed here!') + print*,'ASCII code:',ichar(charq) + call stop1() + end if + return + end + subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey,npages,nsyst,musize,bottreb) + parameter(nm=24,maxblks=4000) + character*65536 bufq + character*1 chax + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*128 lineq + logical lastchar,issegno,isheadr,isvolt,fbon,bottreb, + * newway + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 +c +c Get the first line +c + iccount = 0 + nline = 1 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') then + nline = nline+1 + go to 9 + end if + if (lineq(1:3) .eq. '---') then +c +c Have TeX input until next line that starts with '---' +c +3 nline = nline+1 + call getbuf(lineq) + if (ilbuf .gt. nlbuf) go to 1 + go to 2 +1 print*,'You did not terminate type 0 TeX input with "---"' + call stop1() +2 continue + if (lineq(1:3) .ne. '---') go to 3 +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq and nline are first non-TeX lines. +c + nv = nint(readin(lineq,iccount,nline)) + if (nv .gt. nm) then + write(*,'(1x,a46,i3)') + * 'In setup data, number of voices cannot exceed',nm + call stop1() + end if + noinst = nint(readin(lineq,iccount,nline)) + if (noinst .gt. nv) then + write(*,'(a)') + * 'In setup data, cannot have more instruments than staves' + call stop1() + end if + newway = noinst.le.0 + if (newway) noinst = -noinst + do 10 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if +10 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge!!! +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then + write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8' + call stop1() + end if + xmtrnum0 = readin(lineq,iccount,nline) + newkey = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) + if (fracindent .ge. 1.) then + write(*,'(a)')'In setup data, fracindent must be <1' + call stop1() + end if + if (npages .gt. nsyst) then + print*,'Error in input file: npages > nsyst' + call stop1() + else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then + call printl('Musicsize must be 16, 20, 24, or 29') + call stop1() + end if +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , abs(noinst) +5 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 6 + do 7 iv = 1 , nv +c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then + if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then + call errmsg(lineq,iv,0, + * 'There should be a clef symbol here!') + call stop1() + end if +7 continue + if (lineq(nv+1:nv+1) .ne. ' ') then + call errmsg(lineq,nv+1,0, + * 'There should be a blank here!') + call stop1() + end if +c +c Set flag if voice 1 is treble, since it affects vertical spacing +c + bottreb = lineq(1:1).eq.'t' +c +c Mext non-comment line has path name +c +8 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 8 + lpath = index(lineq,' ')-1 + if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then + call errmsg(lineq,lpath,0, + * 'Last character of pathname is not "/",":", or "' + * //chax(92)//'"!') + call stop1() + end if + return + end + subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c + logical notxtup,shifton,number,btest + character*128 lineq + character*1 charq,dumq + number = .false. + nPBSc = 0 +1 call g1etchar(lineq,iccount,charq) + if (index('PBS:',charq) .gt. 0) then +c +c Continue checking here even if "P". +c + ipbsc = index('PBS:',charq) + if (btest(nPBSc,ipbsc)) then + call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!') + call stop1() +c else if (.not.notxtup .and. ipbsc.gt.2) then +c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') +c call stop1() + end if + nPBSc = ibset(nPBSc,ipbsc) + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (index('+-',charq) .gt. 0) then + call g1etchar(lineq,iccount,dumq) + if (index('.0123456789',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibar,'Expected a number here!') + call stop1() + end if + end if + call readnum(lineq,iccount,dumq,fnum) + if (charq.eq.'-') fnum = -fnum + if (dumq .ne. 'p') then + iccount = iccount-1 + fnum = fnum*wheadpt + end if + go to 1 + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!') + call stop1() + end if +c +c Done with parsing. Other checks +c + if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then + call errmsg(lineq,iccount-1,ibar, + * 'Cannot have both "P" and "B" or "S" and ":"!') + call stop1() + end if + if (btest(nPBSc,4)) then + if (number) then + if (shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Started a group shift without stopping prior one!') + call stop1() + else + shifton = .true. + end if + else + if (.not. shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Ended a group shift without starting one!') + call stop1() + else + shifton = .false. + end if + end if + end if +c +c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) +c + if (iand(nPBSc,26).eq.0) udsp = udsp+fnum + if (.not.number .and. .not.btest(nPBSc,4)) then + call errmsg(lineq,iccount-1,ibar, + * 'Must have either a number or a colon in "X" symbol!') + call stop1() + end if + return + end +c integer*4 function mytime() +c CHARACTER(10) tq +c CALL DATE_AND_TIME(TIME=tq) +c read(tq,'(2i2,f6.3)')ih,im,ts +c mytime = 1000*(ts+60*(im+60*ih)) +c return +c end + subroutine getbuf(lineq) + parameter (maxblks=4000) + character*(*) lineq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) + ipbuf = ipbuf+lbuf(ilbuf) + ilbuf = ilbuf+1 + return + end + subroutine getchar(lineq,iccount,charq) + parameter (nm=24) +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,equalize,stickyS + character*1 charq,rptfq1,rptfq2 + character*128 lineq,lnholdq + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not. endmac) then + iccount = 0 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call mrec1(lineq,iccount,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return +999 continue + lastchar = .true. + return + end + subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount) + parameter (nm=24) + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 durq,chax + character*4 dynsymq + character*128 lineq +c +c Get info for dynamic mark. Enter after getting "D", iccount sits on "D" +c Bits in idyndat are as follows +c 00-03 ivx +c 04-11 ip +c 12-15 code for type of mark +c 0 => arbitrary text +c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff +c If (.not. fontslur) +c 13 => hairpin start, 14,15 => <,> (ending) +c else +c 13 < start, 14 > start, 15 ending +c end if +c 16 flag for vertical offset +c 17-23 vertical offset + 64 , \internote +c 31 Hairpin start (0), stop (1) +c +c idynda2 +c +c 00 flag for horizontal offset +c 01-09 (horizontal offset)/10 + 25.6 notehead widths +c 10 5th bit for ivx (5/15/10) +c + irest = ibset(irest,26) + ndyn = ndyn+1 + idyn = ivx + idynda2(ndyn) = 0 + if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1) + call setbits(idyn,8,4,ip) + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c text-dynamic +c + ntxtdyn = ntxtdyn+1 + iend = iccount+index(lineq(iccount+2:128),'"')+2 + txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) +c +cc Store ivx, ip in bits 0-11 +c Store ivx, ip in bits 0-12 +c +c ivxiptxt(ntxtdyn) = idyn + ivxiptxt(ntxtdyn) = ivx+32*ip + ipm = index('- +',lineq(iend:iend)) + idno = 0 + else +c +c Word-group or hairpin +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) +c +c Exit the loop at first blank, "+", or "-" +c + if (ipm .gt. 0) go to 2 +1 continue +2 continue + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ', + * dynsymq)+3)/4 +c +c Save for later down +c + idno1 = idno + end if +c +c Set flag to check level later if in beam +c + iornq = ibset(iornq,23) + if (idno.ge.14) then +c +c Hairpin here. Check if opposite type from one that's already on +c + if (idno.eq.14.and.btest(listdecresc,ivx) .or. + * idno.eq.15.and.btest(listcresc,ivx)) then + call printl(' ') + call printl('Started one kind of hairpin while other is on') + call stop1() + end if +c +c Start or stop? +c + if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then +c +c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. +c + if (.not.fontslur) idno = 15 + else if (fontslur) then +c +c Start of font slur +c + idno = 13 + else +c +c Start of postscript slur +c + idno = idno-1 + end if + end if +c +c Now that we used list[de]cresc, update +c + if (idno .ge.13) then + if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then +c +c Something's ending +c + if (btest(listcresc,ivx)) then +c +c It's a cresc! +c + listcresc = ibclr(listcresc,ivx) + else + listdecresc = ibclr(listdecresc,ivx) + end if + else +c +c Something's starting +c + if (idno1 .eq. 14) then +c +c It's a cresc! +c + listcresc = ibset(listcresc,ivx) + else + listdecresc = ibset(listdecresc,ivx) + end if + end if + end if + call setbits(idyn,4,12,idno) + iccount = iend + if (ipm .ne. 2) then +c +c There is a vertical shift +c + idyn = ibset(idyn,16) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + call setbits(idyn,7,17,(ipm-2)*idno+64) + ipm = index('- +',durq) + if (ipm .ne. 2) then +c +c There is a horizontal shift +c +c idynda2(ndyn) = ibset(idyn,23) + idynda2(ndyn) = ibset(idynda2(ndyn),0) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256) + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + idyndat(ndyn) = idyn + return + end + subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig, + * itsofar,nodur,figq,ivupfig,nfigs) + logical isfig + character*1 charq + character*10 figq + character*128 lineq +c +c As of 11/26/08, trapped extra figures in getnote, so no need here. +c +c if (ivx .gt. 2) then +cc +cc Read past the figure +cc +c6 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') go to 6 +c return +c end if + nfigs = nfigs+1 + ivupfig = 0 + itoff = 0 + if (charq .eq. 'x') then +c +c Floating figure. +c + call getchar(lineq,iccount,charq) + read(charq,'(i1)')noff + call getchar(lineq,iccount,charq) + read(charq,'(i1)')loff + itoff = noff*ifnodur(loff,'x') + call getchar(lineq,iccount,charq) + else +c +c Figure on a note +c + isfig = .true. + end if + itfig = itsofar+itoff-nodur + lfig = 1 + figq = charq +5 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') then + if (index(' +',charq) .eq. 0) then + figq = figq(1:lfig)//charq + lfig = lfig+1 + go to 5 + else if (charq .eq. '+') then +c +c Get vertical offset for figure. Next character after number has to be blank. +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ivupfig = nint(fnum) + end if + return + end + subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + parameter (nm=24) + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg + character*1 charq,durq + character*20 voltxtq + character*128 lineq,litq + integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm), + * ndlev(nm,2) + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c + 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,iTransAmt(instno(iv))) + 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,iTransAmt(instno(iv)))-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 + return + end + subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) +cccccccccccccccccccccccc +cc +cc GetiTransInfo.for +cc +cccccccccccccccccccccccc +c +c Called from both g1etnote and getnote, after first 'i' in Ki[...] +c On entry, iccount points to last char retrieved, which is 'i' +c +c From1: locgical, true if called from g1etnote +c ibarcnt: tells whether to set EarlyTransOn to true. +c EarlyTransOn set false in blkdata, true here, back to false in topfile. +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; +c LaterInstTrans from getnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c iTransAmt stored as fn of instrument #, not like iTransKey which is +c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This +c simplifies use of iTransAmt for all calls to ifnolev. +c + parameter (nm=24) + logical From1 + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans,store + character*128 lineq + character*1 durq + durq = 'x' ! Can't initialize in declaration stmt, only works once. + if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0 + store = (EarlyTransOn.and.ibarcnt.eq.0) .or. + * (ibarcnt.gt.0.and..not.From1) + LaterInstTrans = .not.From1 .and. ibarcnt.gt.0 + if (store) nInstTrans = 0 +1 continue + if (durq .eq. ' ') return + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be an instrument number here!') + call stop1() + end if + if (store) nInstTrans = nInstTrans+1 + call readnum(lineq,iccount,durq,fnum) + instn = nint(fnum) + if (instn.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Instrument number out of range!') + call stop1() + end if + if (store) iInstTrans(nInstTrans) = instn +c +c durq is +/- following inst # (for iTransAmt), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after instrument number must be "+,-"!') + call stop1() + end if + itramt = 44-ichar(durq) ! +1/-1 for itramt + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a transposition amount here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransAmt(instn) = nint(fnum)*itramt +c +c durq is +/- following iTransAmt (for iTransKey), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after transposition amount must be "+,-"!') + call stop1() + end if + ikey = 44-ichar(durq) ! +1/-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a key indicator here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransKey(nInstTrans) = nint(fnum)*ikey +c +c durq is now 1st character after iTransKey, should be either 'i' or ' ' +c + if (durq.ne.'i'.and.durq.ne.' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be blank or "i" here!') + call stop1() + end if + go to 1 + end + subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,first) +c +c Use this from both pmxa and pmxb to input and check midi data. "first" tells +c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause +c things to be written immediately into the midi storage buffers. +c + parameter (nm=24,mv=24576) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c + integer*2 mmidi,midinum(26) + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + character*1 durq + character*2 instq + character*128 lineq + logical first + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Instrument codes +c + data midinum + * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67, +c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX +c + * 68,69,71,72,74,75, 8,55 / +c bsXobXbaXclXflXreXctXvo +c +1 call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Tempo in beats ber minute +c + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the pause!') + call stop1() +c else if (mmacrec) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot change MIDI tempo while recording a MidiMacro!') +c call stop1() + end if + call readnum(lineq,iccount,durq,qpm) + iccount = iccount-1 + if (.not.first) then + call midievent('t',nint(qpm),0) + gottempo = .true. + end if + go to 1 + else if (durq .eq. 'p') then +c +c Insert a pause. pausemid = pause in 1/4's +c + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here for the pause!') + call stop1() + end if + call readnum(lineq,iccount,durq,pausemid) + iccount = iccount-1 + if (.not.first) then +c +c Compute a meter for the pause. This is only to keep MidiNotate on track. +c Round pause to nearest 16th. Let denominator always be 16. +c + numb16 = nint(pausemid*4) + call midievent('m',numb16,16) +c +c Put in pausemid beats of rest +c + do 3 icm = 0 , numchan-1 + call addmidi(icm,0,0,0,4.*numb16,.true.,.false.) +3 continue + miditime = miditime+nint(240*pausemid) +c +c Restore meter +c + call midievent('m',mtrdenl*lenbar/64,mtrdenl) + end if + go to 1 + else if (durq .eq. 'i') then +c +c Instrument numbers or letters. Expect nv of them. +c + do 2 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (ichar(durq) .gt. 96) then +c +c It's a lowercase letter. Get another, find corr. instrument #. +c + instq(1:1) = durq + call getchar(lineq,iccount,durq) + instq = instq(1:1)//durq + iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'// + * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3 + if (iname .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unrecognized 2-letter midi instrument name!') + call stop1() + end if + midinst(ivx) = midinum(iname)-1 + else +c +c Expect a number, followed by ":" if that is followed by another number. +c I.e., if after call to readnum, durq is not ":", it must be either blank +c or next instrument letter. +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi instrument number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midinst(ivx) = nint(fnum)-1 + if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi instrument number must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 + end if +2 continue + go to 1 + else if (durq .eq. 'v') then +c +c Get volumes for each instrument. Expect nv of them. +c Follow same pattern as for insttrument numbers above. +c + do 7 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi velocity number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midivel(ivx) = nint(fnum)-1 + if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi velocity must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +7 continue + go to 1 + else if (durq .eq. 'b') then +c +c Get balance for each instrument. Expect nv of them. +c Follow same pattern as for instrument numbers above. +c + do 8 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a balance number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midibal(ivx) = nint(fnum)-1 + if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi balance must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +8 continue + go to 1 + else if (durq .eq. 'T') then +c +c Get transposition for each instrument. Expect nv of them. +c Follow similar pattern as above, but separator is +|-. +c + do 9 ivx = 1 , nv + call getchar(lineq,iccount,durq) + ipm = index('-+',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" for midi transposition here!') + call stop1() + end if + ipm = 2*ipm-3 + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + miditran(ivx) = ipm*nint(fnum) +c if (mod(miditran(ivx),12).ne. 0) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Midi transposition limited to multiples of 12!') +c call stop1() +c end if + iccount = iccount-1 +9 continue + go to 1 + else if (durq .eq. 'g') then + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the midi gap!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mgap = nint(fnum) + iccount = iccount-1 + go to 1 + else if (durq .eq. 'M') then +c +c MidiMacros +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'R') then +c +c Start recording +c + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to record a MidiMacro while already recording!') + call stop1() + end if + mmacrec = .true. + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (immac .gt. 20) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MidiMacro ID cannot exceed 20!') + call stop1() + end if +c +c Save the start time +c + mmactime(immac) = miditime + do 4 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then +c +c Adjust if there's a rest at end of prior section. Insert dummy turnoff. +c (This causes two turn-offs in a row, which testmidi sees as an error). +c +c Before: section1 ------rest------- section2(to be recorded) +c After: section1 rest1 now rest2 section2(recorded) +c + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacstrt(icm,immac) = imidi(icm)+1 +4 continue + end if + go to 1 + else if (index('123456789P',durq) .eq. 0) then +c +c End recording; close the open macro. Get immac from common. +c + if (.not.mmacrec) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You tried to end a MidiMacro before starting one!') + call stop1() + end if + mmacrec = .false. + iccount = iccount-1 + if (.not.first) then +c +c Save the macro duration +c + mmactime(immac) = miditime-mmactime(immac) + do 5 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track if needed. +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacend(icm,immac) = imidi(icm) +5 continue + end if + if (durq .ne. ' ')go to 1 + else if (durq .eq. 'P') then +c +c Play Back a Macro +c + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to play a MidiMacro before ending recording!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (mmactime(immac) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a MIDI macro before recording it!') + call stop1() + end if + do 6 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0. + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + end if + end if + msecend(icm,nmidsec) = imidi(icm) + msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac) + msecend(icm,nmidsec+1) = mmacend(icm,immac) + msecstrt(icm,nmidsec+2) = imidi(icm)+1 +6 continue + nmidsec = nmidsec+2 +c +c Update running time +c + miditime = miditime+mmactime(immac) + lasttime = miditime + end if + go to 1 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MidiMacro sub-command!') + call stop1() + end if + else if (durq .eq. 'd') then + debugmidi = .true. + go to 1 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MIDI input data!') + call stop1() + end if + if (.not.gottempo .and. .not.first) then +c +c If no tempo is set on first call on the pmxb pass, then set it +c + call midievent('t',96,0) + gottempo = .true. + end if + return + end + subroutine getnote(loop) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*10 figq + character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax + logical beamon,firstgulp,figbass,figchk,isfig + character*60 cheadq + character*120 instrq,titleq,compoq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp, + * was2,nobar1,quoted,isbj2,stickyS, + * OptLineBreakTies,HeaderSpecial + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /combc/ bcspec + common /comas3/ ask(2500),iask,topmods +c +c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined +c ivx is current ivmx, and is the index for all notes, acc's etc. +c + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comtrans/ cheadq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + common /comclefq/ clefq(nm) + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + character*128 txtdynq + logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur, + * fontslur,WrotePsslurDefaults + character*128 lineq,lnholdq + character*80 headrq, lowerq + character*79 inameq + character*59 hdlndq + character*20 voltxtq + character*1 charq,dotq,durq,ulfbq,dumq + logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved, + * topmods,headlog,btest,sluron,cdot,equalize + character*24 tempq + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1, + * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3 + logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3 + common /combibarcnt/ ibarcnt + cdot = .false. +1 call getchar(lineq,iccount,charq) + if (lastchar) return + if (charq .eq. ' ') go to 1 + if (charq .eq. '%') then +c +c Check for a bar number format: +c + if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and. + * index('bB1234567890',lineq(3:3)).gt.0) then + if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128)) + end if + iccount = 128 + go to 1 + end if +c +c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' +c + if (rptprev) then + rptnd1 = charq .eq. '/' + rptprev = .false. + end if +c +c Repeat at end of a piece +c + if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + * charq.eq.'r') then + if (cdot) go to 28 +c +c This is a note/rest. +c + idotform = 0 + numnum = 0 +c +c If start of line of music, set pitch from previous +c + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv) +c +c notcrd is used to tell if orn. goes on main note or chord note +c +c notcrd = .true. !Move dow. Was not observed if dotted shortcut. +c +c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. +c +28 continue +c +c Moved this from just above, 2 Feb 02 +c + notcrd = .true. + nnl(ivx) = nnl(ivx)+1 + if (ornrpt) then +c +c Replicate ornament bits, also bit 23 for beam handling if chord. +c + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + if (stickyS) then +c +c Grab stemlength shortening parameters from prior note +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + end if + if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then +c +c Doing auto forced beams, and period has been set, so check if this note +c starts a period. +c +c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Start a forced beam here +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + end if + end if + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) + dotq = 'x' + if (charq.eq.'r') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (btest(irest(ivx,nnl(ivx)),0)) then +c +c Rest stuff. First check if previous note was full-bar-pause +c + if (lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1) then + if (btest(islur(ivx,nnl(ivx)-1),19)) + * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + end if +c +c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 +c for voice a or b. Set a-types at 0 as encountered and adjust later +c after '//'. (Override heights will be set to 100+offset) +c + if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if +2 call getchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + ioct = ic-48 + numnum = 2 + go to 2 + else + print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx) + call stop1() + end if + else if (durq .eq. 'd') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then +c +c Double dot. +c + iccount = iccount+1 + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3) + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0) + * go to 2 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19) + call getchar(lineq,iccount,durq) + ndotmv(ivx) = ndotmv(ivx)+1 + iccount=iccount+1 + call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx))) + if (durq .eq. '-') + * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx)) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx))) + if (dumq .eq. '-') + * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx)) + else + rtdot(ivx,ndotmv(ivx)) = 0. + end if + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. 'p') then +c +c Full-bar rest as pause +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'b') then +c +c Blank rest +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Accidental +c + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accidental has been set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Repeated accid, so must be double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + go to 2 + else if (durq .eq. 'i') then +c +c Set flag for MIDI-only accidental. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + go to 2 + else if (index('+-<>',durq) .gt. 0) then + ipm = index('- +',durq)-2 + if (.not.btest(irest(ivx,nnl(ivx)),0)) then +c +c A note, not a rest. +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (moved) go to 2 +c +c Octave jump with a note +c + if (numnum .lt. 2) then + lastlev = lastlev+ipm*7 + else + ioct = ioct+ipm*1 + end if + go to 2 + else +c +c Override default height of a rest +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (lineq(iccount-1:iccount-1) .eq. '.') then +c +c Kluge in case there is a shortcut ".". It will have been sucked up by +c readnum. (Same doesn't hold for ",") +c + iccount = iccount-2 + go to 2 + end if + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) +c +c There may be more characters for this rest +c + iccount = iccount-1 + go to 2 + end if + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. Set flag on this note. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28) +c +c Next input will be digit +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ntup = nint(fnum) + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here xtup number already set but may also +c have this command before. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = 1 + call getchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + end if +c +c Only other possibilities here are ' ' or 'n' +c + if (durq .eq. 'n') then +c +c Alter xtup number +c + if (lineq(iccount+1:iccount+1) .eq. ' ') then +c +c If the only modifier is 'n', cancel the number +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) + else + numshft = 0 +30 call getchar(lineq,iccount,durq) + if (durq .eq. 'f') then +c +c Flip up-down-ness +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14) + go to 30 + else if (index('+-',durq) .gt. 0) then +c +c Vertical or horiz shift +c + numshft = numshft+1 + iofforn = 1 + if (durq .eq. '-') iofforn = -1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + if (numshft .eq. 1) then +c +c Vertical shift +c + iofforn = iofforn*nint(xofforn) + 16 +c +c Turn on bit 1; set bits 2-6 to iofforn +c + irest(ivx,nnl(ivx)) = + * ior(irest(ivx,nnl(ivx)),2+4*iofforn) + else +c +c Horizontal shift +c + iofforn = iofforn*nint(xofforn*10)+16 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7) + call setbits(irest(ivx,nnl(ivx)),5,9,iofforn) + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope adjustment for bracket +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4) + call getchar(lineq,iccount,durq) + iofforn = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + iofforn = nint(iofforn*xofforn+16) + call setbits(mult(ivx,nnl(ivx)),5,5,iofforn) + else if (index('123456789',durq) .gt. 0) then +c +c Replacement printed number +c + call readnum(lineq,iccount,durq,xofforn) + call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn)) + iccount = iccount-1 + go to 30 + end if + end if + end if +c +c Set note level of 1st note of xtup, provided not a rest +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + end if + do 40 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on starting note of xtuplet +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +40 continue + numnum = 0 + nodur(ivx,nnl(ivx)) = 0 + do 6 itup = 2 , ntup + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + nnl(ivx) = nnl(ivx)+1 + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) +7 call getchar(lineq,iccount,charq) + if (charq .eq. ' ') then + go to 7 + else if (charq .eq. '%') then + iccount = 128 + go to 7 + else if (charq .eq. 'o') then +c +c Ornament in xtuplet. "o" symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)-1) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1), + * iornq(ivx,0),ornrpt,noffseg, + * nnl(ivx)-1,ivx,.false.,notcrd,nole) + go to 7 + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx)-1 + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detected preslur in xtuplet loop, non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') islur(ivx,nnlivx) = + * ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + go to 7 + else if (charq .eq. 'G') then +c +c Kluge to get grace in xtup at right location +c + nnl(ivx) = nnl(ivx)-1 + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + nnl(ivx) = nnl(ivx)+1 + go to 7 + else if (charq .eq. sq) then + call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount) + go to 7 + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c Figure. Must come AFTER the first note of xtup +c + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx), + * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) + go to 7 + else if (charq .eq. 'X') then + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)), + * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx, + * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur, + * dotq,ndoub) + go to 7 + else if (charq .eq. 'z') then +c +c Chord note in xtup. Goes with *prior* note. +c + notcrd = .false. + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx)-1 + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +34 call getchar(lineq,iccount,durq) +c +c When chord note is done, will get ' ', making ndx=0, so go past this block +c + ndx = index('fsn+-<>12345678reic',durq) + if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 19) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)-1) = + * ibset(iornq(ivx,nnl(ivx)-1),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14, + * igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20, + * igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)-1) = + * ibset(irest(ivx,nnl(ivx)-1),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else +c +c must be a number, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 34 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 41 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on chord note in xtup +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Following lines copied from loop for non-xtup, chord note, preslur +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0) + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0) + isdat2(nsdat-npreslur+1) = + * ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +41 continue + go to 7 + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)-1),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx)-1 + ArpShift(NumArpShift) = fnum + end if + go to 7 + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1), + * iornq(ivx,nnl(ivx)-1),lineq,iccount) + go to 7 +c+++ + else if (charq .eq. ']') then +c +c Multiplicity up-down, must have '][ ' +c + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20) + iccount = iccount+2 + go to 7 +cc+++ + end if +c +c End of loop for xtup options. If here, charq must be a (non-crd) note name. +c or rest +c + if (charq .eq. 'r') then +c +c Rest in xtup +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then + call getchar(lineq,iccount,durq) + if (durq .eq. 'b') then +c +c Blank rest in middle of xtup +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + else +c +c Override height of embedded xtup rest +c + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) + iccount = iccount-1 + end if + else if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if + notcrd = .true. +8 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then + if (index('+-<>',durq) .gt. 0) then +c +c Accidental horizontal shift +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (.not.moved) then + if (durq.eq.'+') then + lastlev = lastlev+7 + else if (durq.eq.'-') then + lastlev = lastlev-7 + end if + end if + else if (index('fsn',durq) .gt. 0) then + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accid set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Symbol must be repeated, so it's a double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + else if (durq .eq. 'i') then +c +c Set flag for midi-only accidental +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (index('ul',durq) .gt. 0) then +c +c Force stem direction for non-beamed xtup note +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + else if (durq .eq. 'e') then +c +c Left-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then +c +c Right-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = ndoub+1 + else if (durq .eq. 'd') then +c +c Dotted xtup note +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + else +c +c Must be an octave number +c + lastlev = ifnolev(charq,ichar(durq)-48 + * ,iTransAmt(instno(iv))) + end if + go to 8 + end if + if (itup .lt. ntup) then +c +c Last note is handled *after* flowing out of the xtup if block, but still +c within block for a note-rest. Set note level now (rest already done). +c Could have problem here if rests & doubled notes are combined in xtup, +c since might exit the loop at the wrong place. Worry about it later. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + lastlev = lastlev-3+mod(ifnolev(charq,10, + * iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + nodur(ivx,nnl(ivx)) = 0 + do 42 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on internal xtup note +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +42 continue + end if + if (itup .eq. ntup-ndoub) go to 12 +6 continue +12 continue + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if +c +c End of if-block for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c For some purposes, pretend its one bar only +c + nodur(ivx,nnl(ivx)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 + xb4mbr = 0. +20 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48.and.ichar(durq).le.57) then + mbrest = 10*mbrest+ichar(durq)-48 + go to 20 + end if + else if (index('ul',durq) .gt. 0) then +c +c Set stem flipper +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'a') then +c +c "Alone", i.e., prohibit beam +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'r') then +c +c Right offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + go to 2 + else if (durq .eq. 'e') then +c +c Left offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 +c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to +c interbeams = internotes*2/3. +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c End stickyS. Grab data now from prior note, since we have to shut off stickyS. +c + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + stickyS = .false. + go to 2 + end if +c +c If durq .ne. ':' then iccount is now on the start of the number +c + call readnum(lineq,iccount,durq,dum) + call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2)) + if (durq .eq. ':') then + stickyS = .true. + else + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. ',') then +c +c 2:1 pattern +c + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. 'o') then +c +c Suppress rest centering +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25) + go to 2 + else if (durq .eq.'L') then +c +c With keyboard rest option, look left +c + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'A') then +c +c Accidental option +c + call getchar(lineq,iccount,durq) +c + if (durq .eq. 'o') then +c +c Ordered accidentals in a chord. Mark the main note. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28) + else +c +c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29) + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + print*,'Illegal character in note: ',durq,', ivx,nn:', + * ivx,nnl(ivx) + call stop1() + end if +c +c Done with note/rest options. Set level and duration. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + do 43 npreslur = npreslur , 1 , -1 +c +c Set level for preslur on normal note, non-chord +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +43 continue + end if + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (btest(islur(ivx,nnl(ivx)),19)) then +c +c Set duration of full-bar rest as pause +c + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + else if (ibarmbr.ne.nbars+1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + if (btest(islur(ivx,nnl(ivx)),3)) + * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + end if + if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then +c +c Shift is on, and this is not first shifted note. Check for duration change +c + if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then +c +c Must stop and restart the offset. +c + irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1) + end if + end if + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (autofbon .and. tautofb.gt.tol .and. fbon) then +c +c Check to see if need to terminate auto forced beam +c + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Terminate autofb +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + end if + end if + if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then +c +c Finished a bar +c + nbars = nbars+1 + nib(ivx,nbars) = nnl(ivx) + if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then +c +c Just finished the pickup bar for this voice. +c + lenbar = lenb1 + end if + end if + if (idotform .eq. 1) then + call getchar(lineq,iccount,charq) + idotform = 2 + numnum = 1 + go to 28 + else if (idotform .eq. 3) then + call getchar(lineq,iccount,charq) + idotform = 4 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then +c +c Chord note. Must have note name, may have octave#,+,-,s,f,n,d +c Actually the 'd' is not used, since time value comes from +c basic note. Unless dot is to be shifted! +c Doesn't increase # of notes, so must handle separately +c ncrd: index of crd +c Set bit 10 of ipl on main note as flag +c Bits in icrdat: +c 0-7 ip within voice +c 8-11 ivx +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Cautionary accidental +c +c Bits in icrdot: +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx) + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdot(ncrd) = 0 + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +25 call getchar(lineq,iccount,durq) +c ndx = index('fsn+-<>12345678rediA',durq) + ndx = index('fsn+-<>12345678rediAc',durq) + if (ndx .eq. 20) then +c +c Expect +|-|<|> , set tag, loop +c + icrdat(ncrd) = ibset(icrdat(ncrd),29) + go to 25 + else if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 21) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental on chord note +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else if (durq .eq. 'd') then +c +c Must keep 'd' optional (backward compatibility), unless it is moved! +c + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) + * .eq. 0) go to 25 + icrdat(ncrd) = ibset(icrdat(ncrd),26) + call getchar(lineq,iccount,durq) + iccount=iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '+') then + icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64) + else + icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64) + end if + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift specified also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '+') then + ifnum = nint(fnum*10)+64 + else + ifnum = -nint(fnum*10)+64 + end if + else + ifnum = 64 + end if + icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7)) + iccount = iccount-1 + end if + else +c +c must be a single digit, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 25 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 44 npreslur = npreslur , 1 , -1 + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Set level for chord note. +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0) + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0) + isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +44 continue + if (notcrd) then +c +c This is the first chord note in this chord. +c + minlev = min(nolev(ivx,nnl(ivx)),lastlev) + maxlev = max(nolev(ivx,nnl(ivx)),lastlev) + else + minlev = min(minlev,lastlev) + maxlev = max(maxlev,lastlev) + end if + notcrd = .false. + else if (charq .eq. 'G') then + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + continue +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c +c ngrace = ngrace+1 +c ivg(ngrace) = ivx +c ipg(ngrace) = nnl(ivx)+1 +c if (ngrace .eq. 1) then +c ngstrt(ngrace) = 1 +c else +c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) +c end if +c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) +c nng(ngrace) = 1 +c multg(ngrace) = 1 +c upg(ngrace) = .true. +c slurg(ngrace) = .false. +c slashg(ngrace) = .false. +c18 call getchar(lineq,iccount,charq) +c if (index('WA',charq) .gt. 0) then +cc +cc Grace is on note that was already done, so shift flags forward one note. +cc This puts flag on actual note with grace; later for W will go ahead one more. +cc +c ipg(ngrace) = nnl(ivx) +c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) +c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) +c if (slurg(ngrace)) +c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) +c if (charq .eq. 'A') then +cc +cc close After, clear way-after bit, to ensure priority of most recent A/W +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) +c else +cc +cc Way after; later assign to following note, and position like normal grace. +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) +c end if +c else if (charq .eq. 'm') then +c call getchar(lineq,iccount,charq) +c multg(ngrace) = ichar(charq)-48 +c else if (index('123456789',charq) .gt. 0) then +c call readnum(lineq,iccount,durq,fnum) +c iccount = iccount-1 +c nng(ngrace) = nint(fnum) +c else if (charq .eq. 'l') then +c upg(ngrace) = .false. +c else if (charq .eq. 's') then +c slurg(ngrace) = .true. +c if (nnl(ivx) .gt. 0) then +cc +cc If A- or W-grace, set signal to start slur on main note. +cc +c if(btest(ipl(ivx,nnl(ivx)),31) .or. +c * btest(ipl(ivx,nnl(ivx)),29)) +c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) +c end if +c else if (charq .eq. 'x') then +c slashg(ngrace) = .true. +c else if (charq .eq. 'u') then +c else if (charq .eq. 'X') then +cc +cc Space before main note of grace. Number will come next. +cc +c iccount = iccount+1 +c call readnum(lineq,iccount,durq,graspace(ngrace)) +c iccount = iccount-1 +c end if +c if (index('abcdefg',charq) .eq. 0) go to 18 +cc +cc At this point, charq is first note name in grace +cc +c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 +c naccg(ing) = 0 +c ioct = 0 +c if (ing .gt. ngstrt(ngrace)) then +c55 call getchar(lineq,iccount,charq) +c if (charq .eq. ' ') go to 55 +c endif +c iclastlev = 0 +c9 call getchar(lineq,iccount,durq) +c if (durq .ne. ' ') then +c if (durq.eq.'+') then +c lastlev = lastlev+7 +c iclastlev = iclastlev+7 +c else if (durq.eq.'-') then +c lastlev = lastlev-7 +c iclastlev = iclastlev-7 +c else if (index('fsn',durq) .gt. 0) then +c if (naccg(ing) .eq. 0) then +c naccg(ing) = index('fsn',durq) +c else +cc +cc Double accidental +cc +c naccg(ing) = ibset(naccg(ing),2) +c end if +c else +c ioct = ichar(durq)-48 +c end if +c go to 9 +c end if +c if (ioct .gt. 0) then +c lastlev = ifnolev(charq,ioct) +c else +c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c lastlev = ndlev(iv,kv)+iclastlev +c end if +c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) +c end if +c nolevg(ing) = lastlev +c19 continue +cc +cc Grace could come before first note of block, so reset end level. +cc +c if (nnl(ivx).eq.0) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c ndlev(iv,kv) = lastlev +c end if + else if (charq .eq. sq) then +c +c Literal TeX string +c + call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount) + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. Symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)), + * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx, + * .true.,notcrd,nole) + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx) + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detect preslur on normal non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') + * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx) + ArpShift(NumArpShift) = fnum + end if + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx), + * nodur(ivx,nnl(ivx)),figq(ivf,nfig1), + * ivupfig(ivf,nfig1),nfigs(ivf)) + else if (charq .eq. '[') then +c +c Start forced beam. Record barno & time since start of inp. blk. Set signal +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + nadj = 0 + if (autofbon) then + autofbon = .false. + end if +17 call getchar(lineq,iccount,charq) + if (index('ulf',charq) .gt. 0) then + ulfbq(ivx,nfb(ivx)) = charq + go to 17 + else if (charq .eq. 'j') then +c +c Continuing a jumped beam here +c + irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24) +c +c Set flag to watch for END of this forced beam, so can set flag rest(30) on +c NEXT note as signal to start a new notes group there. +c + isbj2 = .true. + go to 17 + else if (charq .eq. 'h') then + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2) + go to 17 + else if (charq .eq. 'm') then +c +c Force multiplicity. Next input is digit +c + call getchar(lineq,iccount,charq) + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) + call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48) + go to 17 + else if (charq .eq. ':') then +c +c Start auto forced beam pattern +c + autofbon = .true. +c +c When forced later beam ends, check whether tautofv <=0; if so set it. +c + tautofb = -itsofar(ivx) + t1autofb = itsofar(ivx) + go to 17 + else if (charq .ne. ' ') then +c +c Must be '+/-' for height or slope shift +c + nadj = nadj+1 +c +c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + iadj = nint(fnum) + if (charq .eq. '-') iadj = -iadj + if (nadj .eq. 1) then +c +c This is a level shift. Note if 0 was entered, iadj = 30 +c + call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30) + else if (nadj .eq. 2) then +c +c Must be a slope shift +c + call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30) + else +c +c Beam-thk fine tune +c + call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj) + end if + go to 17 + end if + else if (charq .eq. ']') then + if (autofbon .and. tautofb.lt.tol) then + tautofb=itsofar(ivx)+tautofb + end if + call getchar(lineq,iccount,charq) + if (index('j ',charq) .gt. 0) then +c +c Since ']' comes AFTER note, itsofar has been updated. Set ending signal. +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + if (charq .eq. 'j') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23) + if (isbj2) then +c +c This is the end of a fb segment of a jump beam. Set flag on NEXT note to +c force start of new notes group, provided this is not last note in bar. +c + if (mod(itsofar(ivx),lenbar) .ne. 0) + * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30) + isbj2 = .false. + end if + else if (charq .eq. '[') then +c +c Multiplicity down-up signal +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) + else if (charq .eq. '-') then +c +c Set signals for gap in single-slope beam [...]-[...] +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20) + nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21) +c +c Next two characters must be "[ ". Skip over them. +c + iccount = iccount+2 + end if + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)), + * iornq(ivx,nnl(ivx)),lineq,iccount) + else if (charq .eq. 'h') then +c +c Heading or height. For heading, only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "h" not at beginning of block' + call stop1() + end if + call getchar(lineq,iccount,durq) + ihdvrt = 0 + if (index('+-',durq) .gt. 0) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ihdvrt = fnum+.1 + if (durq .eq. '-') ihdvrt = -ihdvrt + durq = charq + end if + if (durq .ne. ' ') then +c +c Height symbol. Read past (until next blank) +c +3 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 3 + else +c +c Set flag for header & read it in +c + ihdht = 16 + call getbuf(headrq) + iccount = 128 + end if + else if (charq .eq. 'L') then +c +c Linebreak, already handled in pmxa, but check for movement break +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fmovbrk) + if (durq .eq. 'P') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + end if + if (durq .eq. 'M') then + movbrk = nint(fmovbrk) + movgap = 0 + parmov = -1. + call getchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Get vertical space (\internotes) +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + movgap = nint(fnum) + go to 31 + else if (durq .eq. 'i') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,parmov) + go to 31 + else if (durq .eq. 'c') then + nobar1 = .true. + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then +c +c "rename" can be set on or off. +c + call getchar(lineq,iccount,durq) + rename = durq.eq.'+' + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iiorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iiorig in original list of instruments. +c + nvold = nv + nv = 0 + rename = .true. + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')ninow + else + ninow = ichar(durq)-48 + end if + iiv = 0 + do 63 iinow = 1 , ninow + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow) + else + iiorig(iinow) = ichar(durq)-48 + end if + nspern(iinow) = nsperi(iiorig(iinow)) + nv = nv+nspern(iinow) + sepsymq(iiv+nspern(iinow)) = '&' + if (nspern(iinow) .gt. 1) then + do 64 iis = 1 , nspern(iinow)-1 + sepsymq(iiv+iis) = '|' +64 continue + end if + iiv = iiv+nspern(iinow) +63 continue + 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 (nv.eq.1 .and. nvold.gt.1) then + if (islast) write(11,'(a)')sq//'nostartrule' + else if (nv.gt.1 .and. nvold.eq.1) then + if (islast) write(11,'(a)')sq//'startrule' + end if + iiv = 0 + do 60 iinow = 1 , ninow + do 61 iis = 1 , nspern(iinow) + iiv = iiv+1 +c +c May not really need to re-enter clefs, but it's easier to program since +c clef names are not saved but are needed in newvoice to set ncmidcc. +c + call getchar(lineq,iccount,clefq(iiv)) + call newvoice(iiv,clefq(iiv),.true.) + if (nspern(iinow) .eq. 1) then + hdlndq = chax(48+numclef(clefq(iiv))) + lclf = 1 + else if (iis .eq. 1) then + hdlndq = '{'//chax(48+numclef(clefq(iiv))) + lclf = 2 + else if (iis .lt. nspern(iinow)) then + hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv))) + lclf = lclf+1 + else + hdlndq = + * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}' + lclf = lclf+2 + end if +61 continue +c +c setstaffs & setclef go by instrument, not voice +c + if (islast) then + if (iinow .lt. 10) then + write(11,'(a)')sq//'setstaffs' + * //chax(48+iinow)//chax(48+nspern(iinow))//'%' + write(11,'(a)')sq//'setclef'//chax(48+iinow) + * //hdlndq(1:lclf)//'%' + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinow, + * '}'//chax(48+nspern(iinow))//'%' + write(11,'(a9,i2,a)')sq//'setclef{',iinow, + * '}'//hdlndq(1:lclf)//'%' + end if + end if +60 continue +c +c Loop back up, this may not be last option in M. Note flow out if durq=' ' +c + call getchar(lineq,iccount,durq) + go to 31 + end if +c +c Write instrument names +c + if (.not.rename) then + do 62 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' + else + write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%' + end if + end if +62 continue + else + do 65 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst,'{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + end if + end if +65 continue + rename = .false. + end if + end if + else if (charq .eq.'|' ) then +c +c End of bar symbol. Check about end of bar hardspace. +c + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by a bar line. Remove it from the hardspace +c list, store with shifts instead, set special bit. Need to repeat this code +c at '/'. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + else if (index('wS',charq) .gt. 0) then +c +c Width symbol or new nsyst. Read past (until blank) +c +4 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 4 + else if (charq .eq. 'l') then +c +c Lower string. Only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "l" not at beginning of block' + call stop1() + end if +c +c Set flag for lower string & read it in +c + lower = .true. + call getbuf(lowerq) + iccount = 128 + else if (charq .eq. 'm') then +c +c Meter change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "m" not at beginning of block' + call stop1() + end if + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + call readmeter(lineq,iccount,mtrnmp,mtrdnp) + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenbar = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenbar = lenbar*2 + lenb1 = lenbar + lenb0 = 0 + if (ismidi) call midievent('m',mtrnuml,mtrdenl) + else if (charq .eq. 'C') then +c +c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. +c + if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 + tcc(iv,ncc(iv)) = itsofar(iv) + isl = ibset(islur(iv,nnl(iv)+1),11) + call getchar(lineq,iccount,durq) +c +c Store clef number, or 7 if clef number = 9 (French violin clef) +c + isl = ior(isl,ishft(min(numclef(durq),7),12)) + ncmidcc(iv,ncc(iv)) = ncmidf(durq) +c +c Set marker on note with lowest voice # starting at same time. +c + if (iv .eq. 1) then + isl = ibset(isl,15) + else + do 13 iiv = 1 , iv + nnliiv = nnl(iiv) + if (iiv .eq. iv) nnliiv = nnliiv+1 + itother = 0 + do 14 iip = 1 , nnliiv + if (itother .lt. itsofar(iv)) then + itother = itother+nodur(iiv,iip) + go to 14 + else if (itother .eq. itsofar(iv)) then + islur(iiv,iip) = ibset(islur(iiv,iip),15) + go to 15 + end if +14 continue +13 continue +15 continue + end if +c +c Need 'or' since may have set bit 15 in the above loop +c + islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) + else if (charq .eq. 'R') then +c +c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) +c +10 call getchar(lineq,iccount,durq) +c +c Save designator in case it's a terminal Rr or Rd +c + if (durq .eq. 'l') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5) + go to 10 + else if (index('rdDbz',durq) .gt. 0) then + if (durq .eq. 'r') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6) + else if (durq .eq. 'd') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8) + else if (durq .eq. 'D') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26) + else if (durq .eq. 'b') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25) + else if (durq .eq. 'z') then + iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) + end if + rptprev = .true. + rptfq1 = durq + go to 10 + end if + else if (charq .eq. 'V') then +c +c Ending +c + nnnl = nnl(1)+1 + lvoltxt = 0 +11 call getchar(lineq,iccount,durq) + if (durq.eq.'b' .or. durq .eq.'x') then +c +c End Volta, set bit9, and bit10 on if 'b' (end w/ box) +c + islur(1,nnnl) = ibset(islur(1,nnnl),9) + if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10) + go to 11 + else if (durq .ne. ' ') then +c +c Start volta; Get text +c + if (lvoltxt .eq. 0) then +c +c First character for text +c + lvoltxt = 1 + islur(1,nnnl) = ibset(islur(1,nnnl),7) + nvolt = nvolt+1 + voltxtq(nvolt) = durq + else + voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq + lvoltxt = lvoltxt+1 + end if + go to 11 + end if + else if (charq .eq. 'B') then + bcspec = .not.bcspec + else if (charq .eq. 'P') then +c +c Page numbers. Print stuff right now. +c + npg1 = 0 +c +c Will use ltopnam to signal whether there's a centered heading +c + ltopnam = 0 + ipg1r = 0 +16 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48 .and. ichar(durq).le.57) then + npg1 = npg1*10+ichar(durq)-48 + go to 16 + else if (durq .eq. 'l') then + if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1 + go to 16 + else if (durq .eq. 'r') then + if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1 + go to 16 + else if (durq .eq. 'c') then +c +c Top-centered name. Assume this is last option. Read the name. +c May surround name in double quotes (to allow blanks). +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + ltopnam = lenstr(cheadq,60) + else + namstrt = iccount + if (durq .eq. '"') then +c +c Using quote delimiters. +c + quoted = .true. + namstrt = namstrt+1 + else + quoted = .false. + end if + do 35 iccount = namstrt+1, 128 + if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. + * (.not.quoted .and. lineq(iccount:iccount) .eq. ' ')) + * go to 36 +c +c On exit, iccount is OK, and name is in (namstrt:iccount-1) +c +35 continue + print*,'Awww, cmon, should not be here.' + call stop1() +36 continue + ltopnam = iccount-namstrt + cheadq = lineq(namstrt:iccount-1) + end if + end if +c +c Done getting data, now assemble the command +c + if (npg1.eq.0) npg1=1 +c +c 2/23/03 Don't use \atnextline if on first page and only one system +c +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{' + lhead = 27 +c else +c hdlndq = sq//'toppageno{' +c lhead = 11 +c end if + if (npg1 .lt. 10) then +c +c Note we are overwriting the last "{" +c + write(hdlndq(lhead:lhead),'(i1)')npg1 + else if (npg1 .lt. 100) then + lhead = lhead+3 + write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}' + else + lhead = lhead+4 + write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}' + end if + hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{' + lhead = lhead+2 +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + 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 +c else +c if (ltopnam .eq. 0) then +c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' +c else +c if (islast) +c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' +c end if +c end if + else if (charq .eq. 'W') then +c +c Just eat the number that must follow, it was used in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else if (charq .eq. 'T') then + headlog = .true. + inhead = 0 + call getchar(lineq,iccount,durq) + if (durq .eq. 'i') then + call getbuf(instrq) +c +c A kluge for parts from separate score file for later movements. +c + if (instrq(1:1) .eq. ' ') headlog = .false. + cheadq = instrq + else if (durq .eq. 't') then + call getchar(lineq,iccount,durq) +c +c Optionally can include extra vertical \internotes above inbothd +c + if (index('-+0123456789',durq) .gt. 0) then + ipm = 1 + if (index('+-',durq) .gt. 0) then +c +c Don't trust readnum to round this negative integer properly +c + iccount = iccount+1 + if (durq .eq. '-') ipm = -1 + end if + call readnum(lineq,iccount,durq,fnum) + inhead = ipm*nint(fnum) + end if + call getbuf(titleq) + else + call getbuf(compoq) + end if + inhead = inhead+inbothd + iccount = 128 + else if (charq .eq. 'A') then +c +c Accidental handling etc. +c +27 call getchar(lineq,iccount,durq) + if (durq .eq. 'r') then + if (islast) then + relacc = .true. + write(11,'(a)')sq//'relativeaccid%' + end if + else if (durq .eq. 's') then + bacfac = 1.e6 + else if (durq .eq. 'b') then + if (islast) write(11,'(a)')sq//'bigaccid%' + accfac = bacfac + else if (durq .eq. 'a') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + else if (durq .eq. 'i') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,tintstf) + if (.not.firstgulp) fintstf = tintstf +c +c Local corrections for first page were handled by pmxa +c + iccount = iccount-1 + else if (durq .eq. 'I') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + else if (durq .eq. 'd') then + lowdot = .true. + else if (durq .eq. 'o') then + continue + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call getchar(lineq,iccount,durq) + if (index('-s',durq) .gt. 0) then + fullsize(iiv) = 0.8 + else if (durq .eq. 't') then + fullsize(iiv) = 0.64 + else + fullsize(ivx) = 1.0 + end if +50 continue + else if (durq .eq. 'e') then +c +c Line-spacing equalization +c + equalize = .true. +c +c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. +c But it causes problems with some older scores and when excerpts are combined +c with LaTeX. So as of 2.352 we write it here. +c + write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq + * //'Interligne minus 99'//sq//'Interligne%' + tempq = sepsymq(1) + lentemp = 1 + do 51 iiv = 2 , nv-1 + tempq = tempq(1:lentemp)//sepsymq(iiv) + lentemp = lentemp+1 +51 continue + write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes' + * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}' + * //sq//'en}%' + else if (durq .eq. 'v') then +c +c Toggle usevshrink +c + usevshrink = .not.usevshrink + else if (durq .eq.'p') then +c +c Postscript slurs. fontslur is already false (set in g1etnote) +c + if (.not.WrotePsslurDefaults) then +c +c Set postscrirpt slur adjustment defaults +c + write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust' + * //sq//'nohalfties' + WrotePsslurDefaults = .true. + end if +52 continue + call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l" + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c" + if (durq .eq. '+') then + if (charq .eq. 's') then + write(11,'(a)')sq//'Sluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Tieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'halfties' + else + SlurCurve = SlurCurve + 1 + if (SlurCurve .gt. 3.1) then + call printl('WARNING!') + call printl + * ('Default slur curvature advanced past HH, resetting') + SlurCurve = 3 + end if + end if + else + if (charq .eq. 's') then + write(11,'(a)')sq//'Nosluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Notieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'nohalfties' + else + SlurCurve = SlurCurve - 1 + if (SlurCurve .lt. -1.1) then + call printl('WARNING!') + call printl( + * 'Default slur curvature decremented below f, resetting') + SlurCurve = -1 + end if + end if + end if + go to 52 ! Check for another set of default changes + else if (durq .eq. 'l') then +c +c Set optional linebreak ties +c + OptLineBreakTies = .true. + go to 52 + else if (durq .eq. 'h') then +c +c Set flag to write header special on every page +c + HeaderSpecial = .true. + go to 52 + else + iccount = iccount-1 + end if + else if (durq .eq. 'K') then +c +c Toggle keyboard rest placement flag +c + kbdrests = .not.kbdrests + end if +c if (durq .eq. 'N') then + if (index('NR',durq) .gt. 0) then +c +c Override default part names for scor2prt, or normal include file. +c Just bypass rest of input line +c + iccount = 128 + else if (durq .ne. ' ') then + go to 27 + end if + else if (charq .eq. 'K') then + call getchar(lineq,iccount,durq) + if (durq .ne. 'i') then +c +c Normal, full-score key change and/or transposition +c + num1 = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = num1*nint(fnum) +c +c On exit, durq='+','-'. But only need isig if after start, else done in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (num1 .eq. 0) then +c +c Key change, not transposition. +c + ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28) + lastisig = isig + isig = nint(fnum) + if (durq .eq. '-') isig = -isig + isig = isig+idsig + if (ismidi) call midievent('k',isig,0) + else +c +c num1 .ne. 0, so transposition, so must be at beginning. isig came with K... +c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data +c (signature before transposition). idsig must be added to future key changes. +c + jv = 0 + do while (jv .lt. nm) + jv = jv+1 + iTransAmt(jv) = num1 + end do + idsig = isig-isig0 + end if + else +c +c Instrument specific transposition. + + call GetiTransInfo(.false.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '/') then + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by end of block. Remove it from the hardspace +c list, store with shifts instead, set special bit. This code also at '|' +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + call getchar(lineq,iccount,durq) +c +c Save ending note level: +c + if (ivx .le. nv) then +c +c This is the first line of music on this staff. If previous block had only 1 +c voice, save last pitch from line 1 of prev. block to line 2, in case a +c 2nd line is started just below +c + if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1) + was2(iv) = .false. + ndlev(iv,1) = lastlev + else +c +c This is the 2nd line of music on this staff. +c + was2(iv) = .true. + ndlev(iv,2) = lastlev + end if + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new line of music +c + if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0 + nbars = 0 + if (durq .eq. ' ') then +c +c New line of music is on next staff +c + iv = iv+1 + ivx = iv + else +c +c durq must be 2nd '/'. New line of music is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + nfb(ivx) = 0 + nudoff(ivx) = 0 + ndotmv(ivx) = 0 + do 24 j = 1 , 200 + irest(ivx,j) = 0 + islur(ivx,j) = 0 + nacc(ivx,j) = 0 + iornq(ivx,j) = 0 + ipl(ivx,j) = 0 + mult(ivx,j) = 0 +24 continue +c +c Go back and lower the rests in voice "a" that don't have over-ridden heights +c + do 26 j = 1 , nnl(iv) + if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0) + * nolev(iv,j) = -4 +26 continue + end if + end if + iccount = 128 + else if (charq .eq. 'X') then +c +c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, +c which only happens for normal X at block start, and we took special measures to +c keep group shifts for crossing block boundaries. +c + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))), + * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx, + * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub) + else if (charq .eq. 'I') then +c +c Midi controls. +c + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.false.) + else if (charq .eq. 'M') then +c +c Macro action +c + call getchar(lineq,iccount,charq) + if (index('RS',charq) .gt. 0) then +c +c Record or save a macro. Get the number of the macro. +c + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call mrec1(lineq,iccount,ndxm) + else +c +c Save (Record but don't activate) +c +5 call mrec1(lineq,iccount,ndxm) + if (mrecord) then + call getbuf(lineq) + iccount = 0 + go to 5 + end if + iccount = iccount+ndxm+1 + end if + else if (charq .eq. 'P') then +c +c Playback the macro +c + call getchar(lineq,iccount,charq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + icchold = iccount + lnholdq = lineq + iccount = 128 + ilmac = il1mac(macnum) + mplay = .true. + end if + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Check for start of forced beam on 2nd member of dotform=1 shortcut +c + if (fbon) then + if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx)) + * t1fb(ivx,nfb(ivx)) = + * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2 + end if +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + end if + return + end + subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg, + * ip,ivx,noxtup,notcrd,nole) +c +c iornq: Main note. Do not alter if chord note, except turn on bit 23 +c iornq0: Store iorni + bit 23, in case of repeated ornaments +c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. +c noffseg: horiz. offset for segno +c nole: level of note w/ orn, used to ID the note/orn if there's a level shift. +c + + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comcb/ nbc,ibcdata(36) + character*1 charq,durq + character*128 lineq + logical ornrpt,negseg,noxtup,notcrd +c +c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U +c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD +c + call getchar(lineq,iccount,charq) + if (index('bc',charq) .gt. 0) then +c +c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) +c ivx(0-3,28), ip(4-12), +c vshift (vshift+32 in bits 13-18), +c hshift (nint(10*vshift)+128 in bits 19-26) +c bit 27 = 0 if caesura, 1 if breath +c bit 28: 5th bit of ivx +c + iornq = ibset(iornq,28) + nbc = nbc+1 +c ibcdata(nbc) = ivx+16*ip + ibcdata(nbc) = mod(ivx,16)+16*ip + if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28) + if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27) + call getchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c We have a vertical shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),6,13,nint(32+fnum)) + if (index('+-',charq) .gt. 0) then +c +c Horizontal shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128) + end if + end if + return + end if +c +c Set signal on main note that some note at this time has ornament. ONLY used +c in beamstrt to activate further tests for whether ihornb is needed. +c + iornq = ibset(iornq,23) +c +c Isolate 21 bits defining exisiting ornaments +c + if (notcrd) then + iorni = iand(4194303,iornq) + else + iorni = iand(4194303,icrdorn(ncrd)) + end if + korn = index('stmgx+Tupf._)e:XXX>^',charq) + if (korn .ne. 15) iorni = ibset(iorni,korn) +c +c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later +c as follows: korn=16-18 for sfn, and or 21 for bare ?. +c When this if-block is done, korn will = bit# of actual ornament (unless "?"). +c + if (korn .eq. 15) then +c +cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq +c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq +c +c iorni = ior(iorni,iand(iornq0,1638383)) + iorni = ior(iorni,iand(iornq0,3735535)) + ornrpt = .false. + call getchar(lineq,iccount,durq) +c +c durq will be ' ' +c + else if (korn .eq. 14) then +c +c Editorial accidental +c + call getchar(lineq,iccount,durq) +c korn = 15+index('sfn',durq) + korn = 15+index('sfn?',durq) + if (korn .eq. 19) korn=21 + iorni = ibset(ibclr(iorni,14),korn) + call getchar(lineq,iccount,durq) + if (durq .eq. '?') then +c +c This is "oe[s|f|n]?". Set 21st bit also. +c + iorni = ibset(iorni,21) + korn = korn+6 + call getchar(lineq,iccount,durq) + end if +c iorni = ibset(ibclr(iorni,14),korn) + else if (korn.eq.4 .and. noxtup) then +c +c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points +c + noffseg = 0 + negseg = .false. + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Segno shift is specified +c + if (durq .eq. '-') then + negseg = .true. + call getchar(lineq,iccount,durq) + end if + call readnum(lineq,iccount,durq,fnum) + noffseg = int(fnum) + if (negseg) noffseg = -noffseg + end if + else if (korn .eq. 7) then +c +c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = ip + xnsktr(ntrill) = 1. + call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Convert to new internal symbol for non-'"tr" trill +c + korn = 15 + iorni = ibset(ibclr(iorni,7),15) + call getchar(lineq,iccount,durq) + end if + if (index('0123456789.',durq) .gt. 0) then +c +c We have a number for the length +c + call readnum(lineq,iccount,durq,xnsktr(ntrill)) + end if + else if (korn.eq.10 .and. noxtup) then +c +c Fermata +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'd') then + korn = 14 + iorni = ibset(ibclr(iorni,10),14) + call getchar(lineq,iccount,durq) + end if + else + call getchar(lineq,iccount,durq) + end if + if (index('+- :',durq) .eq. 0) then + print*,'Unexpected character at end of ornament: ',durq + call stop1() + end if + if (index('+-',durq) .gt. 0) then +c +c Shift ornament up or down +c + nudorn = nudorn+1 +c +c Set bit 25 in iorni as a signal. This may not really be necessary. +c + iorni = ibset(iorni,25) +c +c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, +c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present +c + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iofforn = nint(xofforn*fnum) + kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12) + * +ishft(korn,19)+ishft(iofforn+32,25) + ivxudorn(nudorn) = ivx + if (index('+-',durq) .gt. 0) then +c +c Horizontal shift +c + kudorn(nudorn) = ibset(kudorn(nudorn),31) + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ornhshft(nudorn) = nint(xofforn*fnum) + end if + else if (durq .eq. ':') then +c +c Turn on repeated ornaments +c + ornrpt = .true. +c +c Save the ornament value just set +c + iornq0 = iorni + end if + if (notcrd) then + iornq = ior(iornq,iorni) + else + icrdorn(ncrd) = ior(icrdorn(ncrd),iorni) + end if + return + end + subroutine getpmxmod(global,includeq) +c +c If global=.true., checks for environment variable with path to pmx.mod. +c Then, if variable exists and points to pmx.mod, insert lines from +c pmx.mod into buffer +c If global=.false., checks for existence of includeq and uses it. +c +c lenbuf0 = total length of bufq on entry +c lbuf(i) = length of line (i) +c nlbuf = number of lines stored in bufq +c ilbuf = index of first line after setup stuff (on entry). In general, index of +c next line to be sucked from buffer. +c ilbufmod = counter for lines in pmx.mod as they are grabbed. +c Starts at ilbuf. Points to position of next line after +c pmx.mod stuff in bufq on exiting loop 1 +c ilbuff = transient counter for shifting operations +c ipbuf = on entry, points to last character in setup stuff. In general, points +c to last character of most recent line sucked from buffer. +c ipbufmod = points to last character of most recent inserted line +c from pmx.mod +c + parameter (maxblks=4000,nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,fbon,issegno,isheadr,isvolt + character*(*)includeq + character*80 pmxmoddirq + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical fexist,global + line1pmxmod = ilbuf + if (.not.global) then + inquire(file=includeq,EXIST=fexist) +c +c Transfer includeq to temporary char variable with known length +c + pmxmoddirq = includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + print* + write(15,'()') + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', checking further.') +c +c File named includeq doesn't not exist. Get directory from PMXMODDIR and +c see if it's there +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq. gt. 0) then + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + else + call printl( + * 'No other directory defined by PMXMODDIR, stopping') + call stop1() + end if + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', stopping.') + call stop1() + end if + end if + call printl('Opening normal include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq) + else +c +c Check for existence of pmx.mod +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq .eq. 0) return + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod' + lpmxmoddirq = lpmxmoddirq+7 + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) return + call printl('Opening global include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq(1:lpmxmoddirq)) + end if + call printl('Adding include data') +c +c Read lines in from pmx.mod one at a time +c + ipbufmod = ipbuf + lenbufmod = lenbuf0 + do 1 ilbufmod = ilbuf , maxblks + read(18,'(a)',end=3)lnholdq +c +c A line was read. Slide all existing lengths from here forward ahead by 1 +c + do 2 ilbuff = nlbuf , ilbufmod , -1 + lbuf(ilbuff+1) = lbuf(ilbuff) +2 continue +c +c Get length of line from include file +c + lenmodline = lenstr(lnholdq,128) + if (lenmodline .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lenmodline = 1 + lnholdq = ' ' + end if + lbuf(ilbufmod) = lenmodline + call printl(lnholdq(1:lenmodline)) +c +c Insert new stuff into bufq +c + bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)// + * bufq(ipbufmod+1:lenbufmod) +c +c Update internal parameters +c + ipbufmod = ipbufmod+lbuf(ilbufmod) + lenbufmod = lenbufmod+lbuf(ilbufmod) + nlbuf = nlbuf+1 +1 continue +3 continue + call printl('Closing '//pmxmoddirq(1:lpmxmoddirq)) + close(18) + linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf + lenbuf0 = lenbufmod +c +c Fix Andre's error reporting problem 101211 leading to log(neg#) due +c to nline being 2 bigger than it should be +c + nline=nline-2 +c + return + end + subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0, + * inameq,clefq,sepsymq,pathnameq,lpath,isig0) + parameter (nm=24) + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*1 clefq(nm),sepsymq(nm) + character*40 pathnameq + character*79 inameq(nm) + character*128 lineq + logical istype0,newway,rename +c +c Get the first line +c + iccount = 0 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 9 + istype0 = lineq(1:3).eq.'---' + if (istype0) then +c +c Have TeX input until next line that starts with '---'. Save in scratch. +c + open(17,status='SCRATCH') +3 call getbuf(lineq) + if (lineq(1:3) .ne. '---') then + write(17,'(a)')lineq + go to 3 + end if +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq is first line w/ numerical setup data. +c + nv = nint(readin(lineq,iccount,nline)) + noinst = nint(readin(lineq,iccount,nline)) + newway = noinst.le.0 + if (newway) noinst = -noinst + do 2 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then +c +c Read in nvi for each instrument +c + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if + iiorig(iinst) = iinst + nspern(iinst) = nsperi(iinst) +2 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge to make mtrdenl work +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + xmtrnum0 = readin(lineq,iccount,nline) +c +c Original key sig (before any trnasposition) in next position. Transposed +c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key +c changes if transposed. +c + isig0 = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musicsize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , noinst +5 call getbuf(inameq(i)) + if (inameq(i)(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 6 + iv = 0 + nvsofar = 0 + do 1 jinst = 1 , noinst + nvsofar = nvsofar+nsperi(jinst) + do 10 ivi = 1 , nsperi(jinst) + iv = iv+1 + clefq(iv) = lineq(iv:iv) + if (iv .eq. nvsofar) then + sepsymq(iv) = '&' + else + sepsymq(iv) = '|' + end if +10 continue +1 continue +c +c Mext non-comment line has path name +c +8 call getbuf(pathnameq) + if (pathnameq(1:1) .eq. '%') go to 8 + lpath = index(pathnameq,' ')-1 + return + end + function getsquez(n,ntot,space,tnote,to) + real*4 tnote(600),to(600) + common /comtol/ tol +c +c Get the squez factor by checking space against tgovern=minimum duration +c of all notes sounding at time of n-th note in the list. +c The starting time of base increment is to(n) and ending time is to(n)+space +c Sounding notes are those that start at or before to(n) .and. end at or +c after tend=to(n)+space +c Since notes are ordered by increasing start times, as soon as we find one +c that starts too late, we are done checking. +c + tgovern = 1000. + tend = to(n)+space + do 1 in = 1 , ntot +c +c Since to() is ordered by start times, exit loop after first note that +c starts later than note of interest. +c + + if (to(in) .gt. to(n)+tol) go to 2 + if (to(in)+tnote(in) .gt. tend-tol) then +c +c If here, this note overlaps and must be tested. +c + tgovern = min(tgovern,tnote(in)) + end if +1 continue +2 continue + getsquez = space/tgovern + return + end + subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx, + * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub) + parameter(nm=24) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c Since during getnote phase time is integer itsofar, which is not updated +c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if +c not in xtup. +c + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical shifton,colon,ess,number + character*128 lineq + character*1 charq,durq,dotq + colon = .false. + ess = .false. + number = .false. + nextbl = iccount+index(lineq(iccount:128),' ')-1 + if (index(lineq(iccount:nextbl),'P') .gt. 0) then +c +c "Parts only", ignore entire symbol +c + iccount = nextbl + return + end if +1 call getchar(lineq,iccount,charq) + if (charq.eq.'B') then +c +c "Both parts and score," ignore character +c + go to 1 + else if (charq .eq. ':') then + colon = .true. + go to 1 + else if (charq .eq. 'S') then + ess = .true. + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (charq.eq.'-') iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum = -fnum + if (durq .ne. 'p') then + fnum = fnum*wheadpt + iccount = iccount-1 + end if + go to 1 + end if +c +c charq must be blank, so done parsing +c + if (.not.ess .and. .not.colon) then +c +c Ordinary hardspace. Goes before next note. +c (Later, at "|" or "/", check for presence and switch to udoff if there!) +c + nudsp = nudsp+1 + iornq1 = ibset(iornq1,26) + udsp(nudsp) = fnum + tudsp(nudsp) = itsofar + if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp) +c * +float(itup-1)/ntup*ifnodur(nnodur,dotq) + * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq) + else if (.not.number) then +c +c Must be "X:" End a group offset. +c + irest = ibset(irest,17) + shifton = .false. + return + else +c +c Only other possibility is start offset, "S" for single, ':' for multiple +c + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = fnum + if (ess) then + irest1 = ibset(irest1,15) + else + irest1 = ibset(irest1,16) + shifton = .true. + end if + end if + return + end + function i1fnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + i1fnodur=1 + else if (idur .eq. 3) then + i1fnodur=2 + else if (idur .eq. 1) then + i1fnodur=4 + else if (idur .eq. 8) then + i1fnodur=8 + else if (idur .eq. 4) then + i1fnodur=16 + else if (idur .eq. 2) then + i1fnodur=32 + else if (idur .eq. 0) then + i1fnodur=64 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + i1fnodur=4 + else if (idur .eq. 9) then + i1fnodur = 128 + else + print* + print*,'You entered an invalid note-length value:',idur + call stop1() + end if + if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2 + return + end +c integer*4 function longi(ishort) +c integer*2 ishort +c longi = ishort +c return +c end + function iashft(nacc) + integer*4 ias(6) + data ias /-1,1,0,0,-2,2/ + iashft = ias(nacc) + return + end + function ifnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + ifnodur=1 + else if (idur .eq. 3)then + ifnodur=2 + else if(idur .eq. 1) then + ifnodur=4 + else if(idur .eq. 8) then + ifnodur=8 + else if(idur .eq. 4) then + ifnodur=16 + else if(idur .eq. 2) then + ifnodur=32 + else if(idur .eq. 0) then + ifnodur=64 + else if(idur .eq. 9) then + ifnodur=128 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + ifnodur=4 + else + print*,'You entered an invalid note value' + stop + end if + if (dotq .eq. 'd') ifnodur = ifnodur*3/2 + return + end + function ifnolev(noq,oct,ntrans) + character*1 noq + integer oct + ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans + return + end +c subroutine report(nsdat,isdat1,isdat2) +c integer*4 isdat1(202),isdat2(202) +c write(*,'(a)') +c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' +c do 1 isdat = 1 , nsdat +c isdata = isdat1(isdat) +c ionoff = igetbits(isdata,1,11) +cc iv = iand(7,isdata) +c iv = igetbits(isdata,5,13) +c kv = igetbits(isdata,1,12)+1 +c ip = igetbits(isdata,8,3) +c idcode = igetbits(isdata,7,19) +c iud1 = igetbits(isdata,1,26) +c iud2 = igetbits(isdata,1,27) +c ndxslur = igetbits(isdata,4,28) +c isdatb = isdat2(isdat) +c ivo = igetbits(isdatb,6,6)-32 +c iho = igetbits(isdatb,7,12)-64 +c lev = igetbits(isdatb,7,19) +c icrd = igetbits(isdatb,1,0) +c lhd = igetbits(isdatb,1,1) +c irhd = igetbits(isdatb,7,2) +c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, +c * ivo,iho,lev,icrd,lhd,irhd +c1 continue +c print* +c return +c end + function igetbits(isdata,iwidbit,ishift) +c +c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and +c then added to ioff +c + igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift)) + return + end + function igetvarlen(mmidi,icm,imidi,nbytes) +c +c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. +c + parameter (nm=24,mv=24576) + integer*2 mmidi(0:nm,mv) + igetvarlen = 0 + do 1 nbytes = 1 , 4 + igetvarlen = 128*igetvarlen + * +iand(127,mmidi(icm,imidi+nbytes)) +c * +iand(127,longi(mmidi(icm,imidi+nbytes))) + if (.not.btest(mmidi(icm,imidi+nbytes),7)) return +c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return +1 continue + print*,'Messup in igetvarlen' + call stop1() + end + logical function isdotted(nodur,ivx,ip) + parameter (nm=24) +c +c Function returns true if note is dotted or double-dotted. +c Return false for any xtuplet. +c + common /comtol/ tol + integer*4 nodur(nm,200) + if (nodur(ivx,ip) .eq. 0) then + isdotted = .false. + return + else if (ip .gt. 1) then + if (nodur(ivx,ip-1) .eq. 0) then + isdotted = .false. + return + end if + end if +c +c Ruled out all xtups, so is dotted or double-dotted if not a power of 2. +c + isdotted = + * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol + return + end + function isetvarlen(idur,nbytes) + isetvarlen = 0 + itemp = idur + do 1 nbytes = 1 , 4 + isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1) + itemp = ishft(itemp,-7) + if (itemp .gt. 0) then + isetvarlen = isetvarlen+2**(8*nbytes+7) + else + return + end if +1 continue + print*,'Problem in function isetvarlen' + call stop1() + end + subroutine istring(i,string,len) +c +c Returns string with integer only if length is 1, otherwise enclosed in +c brackets. +c + character*(*) string + if (i .ne. 0) then + len = alog10(abs(i)*1.0001)+1 + if (i .lt. 0) len = len+1 + else + string = '0' + len = 1 + return + end if + if (len .eq. 1) then + string = char(48+i) + else + string = '{' + write(string(2:1+len),'(i'//char(48+len)//')')i + string = string(1:len+1)//'}' + len = len+2 + end if + return + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + function levrn(nolev,irest,iud,ncm,mult) +c +c Used for placing numbers in xtups. Returns note level if not a rest, +c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. +c + logical btest + if (.not.btest(irest,0)) then + levrn = nolev + else +c +c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. +c + if (mult .gt. 0) then + if (mult .eq. 2) then + ioff = -1+2*iud + else if (mult .ne. 4) then + ioff = iud*mult + else + ioff = 1+4*iud + end if + else +c +c May need to futz with this later for non-beamed xtups (quarter, half rests) +c + ioff = iud*2 + end if + levrn = mod(nolev+20,100)-20+ncm+ioff + endif + return + end + function lfmt1(x) +c +c Computes total length of an "f" format with one decimal place. +c First round to nearest 0.1 +c + if (abs(x) .lt. .001) then + lfmt1 = 2 + else + y = sign(.1*int(10*abs(x)+.5),x) + lfmt1 = int(log10(1000*abs(y)+.001)) + if (y .lt. 0) lfmt1 = lfmt1+1 + end if + return + end + subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + parameter (nm=24) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie + character*1 udq,chax,sepsymq(nm) + character*8 noteq + character*128 notexq +c +c This is called twice from pmxb after having input an entire block, before +c making a bar that starts a new system. So nsdat reflects all slur starts +c and stops in new block, while listslur, which is only set when bars are +c made, reflects only open slurs from the old block. So we must check +c listslur to find open ties, not all nsdat. +c First of two calls (ispstie=.false. on entry) terminates tie at end of line. +c Second (ispstie=.true. on entry) restarts tie at start of new line. Only +c need data from original tie-start for both of these. Tie/slur data from +c closing of full tie are not used except for shape alterations. +c +c do 1 ndx = 0 , 11 + do 1 ndx = 0 , 23 + if (btest(listslur,ndx)) then +c +c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie +c + do 2 isdat = 1 , nsdat +c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index + if (igetbits(isdat1(isdat),4,28) + * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index + if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop + if (btest(isdat2(isdat),3)) go to 3 ! "st" + idcode = igetbits(isdat1(isdat),7,19) + if (idcode.eq.1) go to 3 ! "t" + tie = .false. + go to 5 +2 continue + end if + go to 1 +3 continue + tie = .true. +5 continue +c +c A slur or tie is open, with index ndx +c + iv = igetbits(isdat1(isdat),5,13) + kv = igetbits(isdat1(isdat),1,12)+1 + udq = 'd' + if (btest(isdat1(isdat),27)) udq='u' + notexq = chax(92)//'znotes' + lnote = 7 + do 4 iiv = 1 , iv-1 + notexq = notexq(1:lnote)//sepsymq(iiv) + lnote = lnote+1 +4 continue + if (kv .eq. 2) then + notexq = notexq(1:lnote)//chax(92)//'nextvoice' + lnote = lnote+10 + end if +c +c Compute horiz and vert offsets +c +c nolev = igetbits(isdat2(isdat),7,19) + islhgt = igetbits(isdat3(isdat),8,14) + ilb12 = 0 + if (ispstie) ilb12 = 1 + ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32 + if (ivoff .eq. -32) ivoff = 0 +C nolev = nolev+ivoff + islhgt = islhgt+ivoff + ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff + if (ihoff .eq. -64) ihoff = 0 +c +c Add starting stuff for command +c + if (.not.ispstie) then ! End 1st segment + notexq = notexq(1:lnote)//chax(92)//'roffset{' + lnote = lnote+9 +c hoff = ihoff*.1-.5 +c hoff = ihoff*.1-.8 + hoff = ihoff*.1-.4 + if (hoff .lt. 0) then + hoff = -hoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(hoff,notexq,lnote) + notexq = notexq(1:lnote)//'}{' + lnote = lnote+2 + else + notexq = notexq(1:lnote)//chax(92)//'off{-' + * //chax(92)//'afterruleskip}' + lnote = lnote+21 +c +c 091025 add dotting for 2nd segment if needed +c + if (btest(isdat2(isdat),4)) then + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if + end if + if (ispstie .and. tie) then + notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq + lnote = lnote+10 + end if + if (btest(isdat3(isdat),0)) then +c +c Curvature tweak on termination of 1st seg +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: +c Abs(imid) Postscript slur type +c 1 f +c 4 h +c 5 H +c 6 HH +c + notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid) + lnote = lnote+9 +c +c Zero out the flag in case there's a different curv on term of 2nd, +c + isdat3(isdat) = ibclr(isdat3(isdat),0) + end if +c +c Add the command name +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'is'//udq + lnote = lnote+4 + else if (tie) then + notexq = notexq(1:lnote)//chax(92)//'ttie' + lnote = lnote+5 + else + notexq = notexq(1:lnote)//chax(92)//'tslur' + lnote = lnote+6 + end if +c +c Add index +c +c if (11-ndx .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndx) +c lnote = lnote+1 +c else +c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' +c lnote = lnote+4 +c end if + if (23-ndx .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndx) + lnote = lnote+1 + else if (23-ndx .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}' + lnote = lnote+4 + end if + if (ispstie .or. .not.tie) then +c +c Add note name for slur height +c + noctup = 0 + ncm = igetbits(isdat3(isdat),8,22) + if (ncm .eq. 23) noctup = -2 +c call notefq(noteq,lnoten,nolev,ncm) + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}' + lnote = lnote+1+lnoten+1 + end if + if (ispstie) then +c +c Horizontal shift start of new thing +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 +c ihoff = ihoff-13 + if (tie) then + ihoff = ihoff-12 + else + ihoff = ihoff-7 + end if + if (ihoff .lt. 0) then + ihoff = -ihoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(ihoff*.1,notexq,lnote) + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Add closing stuff +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'off{' + * //chax(92)//'afterruleskip}' + lnote = lnote+20 + else + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//chax(92)//'en%' + lnote = lnote+4 + write(11,'(a)')notexq(1:lnote) +1 continue + ispstie = .not.ispstie + return + end + subroutine littex(islur,nnl,iv,topmods,lineq,iccount) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + integer islur(nm,200) + logical topmods + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,merge + character*128 lineq,litq + character*20 voltxtq + character*1 durq,chax + merge = .false. + if (nlit .gt. 0) then + merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit) + end if + nlit = nlit+1 + ivlit(nlit) = iv + iplit(nlit) = nnl + itype = 1 +17 call getchar(lineq,iccount,durq) + if (durq .eq. chax(92)) then + itype=itype+1 + go to 17 + end if + litq(nlit) = chax(92)//durq + lenlit(nlit) = 2 +18 call getchar(lineq,iccount,durq) + if (durq.eq.chax(92)) then + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Starting a new tex command within the string +c + litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq + lenlit(nlit) = lenlit(nlit)+2 + go to 18 + end if + else + litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq + lenlit(nlit) = lenlit(nlit)+1 + go to 18 + end if +c +c If here, just read backslash-blank so string is done +c + if (itype .eq. 1) then + islur(iv,nnl) = ibset(islur(iv,nnl),16) + if (merge) then +c +c There are 2 separate strings on the same note, so merge them. +c + nlit = nlit-1 + litq(nlit) = litq(nlit)(1:lenlit(nlit)) + * //litq(nlit+1)(1:lenlit(nlit+1)) + lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1) + if (lenlit(nlit) .gt. 128) then + print* + print*, + * 'Merged type-1 TeX strings longer than 128 characters' + write(15,'(/,a)') + * 'Merged type-1 TeX strings longer than 128 characters' + call stop1() + end if + end if + else + if (itype .eq. 3) then +c +c Write the string NOW +c + if (islast) + * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + else +c +c Must go at top +c + if (.not.topmods) then + topmods = .true. + open(16,status='SCRATCH') + end if +c +c Must write '%' here rather than later, in case string ends with blank. +c + write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + end if + nlit = nlit-1 + end if + return + end + function llen(strq,n) + character*129 strq + do 1 llen = n , 0 , -1 + if (strq(llen:llen) .ne. ' ') return +1 continue + end + function log2(n) +c +c 5/25/08 Modify to allow more slurs +c +c log2 = alog(1.*n)/0.6931472+.0001 +c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 + log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0 + return + end + subroutine logbeam(numnew,nip1,nip2) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq,ulfq,ulfbq + logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest, + * autofbon + ibm1(ivx,numnew) = nip1 + ibm2(ivx,numnew) = nip2 + numnow = numnew + if (numnew .gt. 1) then +c +c If it starts before any others, must put it in order +c + do 11 ib = numnew-1 , 1 , -1 + if (ibm1(ivx,ib) .lt. nip1) go to 12 + ibm1(ivx,ib+1) = ibm1(ivx,ib) + ibm2(ivx,ib+1) = ibm2(ivx,ib) + ulq(ivx,ib+1) = ulq(ivx,ib) + ibm1(ivx,ib) = nip1 + ibm2(ivx,ib) = nip2 + numnow = ib +11 continue +12 continue + end if + sum = 0. +c +c Beam has non-xtup within +c + nrests = 0 + isxtup = .false. + do 9 iip = nip1 , nip2 + if (btest(islur(ivx,nip1),21)) then +c +c Forced multiplicity +c +c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) + call setbits(mult(ivx,iip),4,0, + * igetbits(islur(ivx,nip1),3,22)+8) + else if (.not.isxtup) then + if (nodur(ivx,iip) .gt. 0) then +c mult(ivx,iip) = 4-log2(nodur(ivx,iip)) + call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8) + else +c +c Start xtup within forced beam +c + isxtup = .true. + iip1 = iip + end if + else if (isxtup .and. nodur(ivx,iip).gt.0) then +c +c End of xtup within forced beam. Must count doubled notes +c + ndoub = 0 + do 1 iiip = iip1 , iip + if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1 +1 continue + multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)- + * alog(nodur(ivx,iip)/2.))/0.69315)-10 + do 74 iiip = iip1 , iip +c mult(ivx,iiip) = multx + call setbits(mult(ivx,iiip),4,0,multx+8) +c +c Note the following still works after making mult only the 1st 4 bits. +c + if (btest(nacc(ivx,iiip),18)) + * mult(ivx,iiip) = mult(ivx,iiip)-1 + if (btest(nacc(ivx,iiip),19)) then + mult(ivx,iiip) = mult(ivx,iiip)+1 + else if (iiip .gt. 1) then + if (btest(nacc(ivx,iiip-1),19)) + * mult(ivx,iiip) = mult(ivx,iiip)+1 + end if +74 continue + isxtup = .false. + end if + if (btest(irest(ivx,iip),0)) then + nrests = nrests+1 + else + sum = sum+nolev(ivx,iip) + end if +9 continue +c +c Set beam up-down-ness +c + if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then + if (ulfbq(ivx,ifb) .eq. 'f') then +c +c Get default, then trade "l" and "u" +c + ulq(ivx,numnow) = char(225-ichar( + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)))) + else + ulq(ivx,ifb) = ulfbq(ivx,ifb) + end if +c +c This probably works only because forced beams are done first, so they +c don't have to be re-sorted within each voice. ???? +c + else if (nvmx(iv) .eq. 2) then +c +c Multi-voice per staff +c + if (ivx .le. nv) then + ulq(ivx,numnow) = 'l' + else + ulq(ivx,numnow) = 'u' + end if + else +c +c Defaults +c + ulq(ivx,numnow) = + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)) + end if + return + end + subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + logical mrecord,mplay,endmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lbuf(1) = lbuf(1) + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then + call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1, + * 'Improper macro termination!') + call stop1() + end if + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + parameter (nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst + common /comeskz2/ eskz2(nm,200) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm), + * numbms(nm),mapfb(16) + real*4 xit(nm),t1xtup(20),tstart(80),squez(80) + character*1 ulfbq + character*79 inameq + character*20 voltxtq + common /comoct/ noctup + character*80 headrq,lowerq + logical cwrferm + common /comcwrf/ cwrferm(nm) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical lower,cwrest(nm),vxtup,flgndb,btest,upslur, + * infbmx(nm),lowdot,inxtup(nm),drawbm + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Above are factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur, + * WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comntot/ ntot + if (ismidi) then +c +c Initialize for this bar the accidental counter for the midi file. +c naccim(icm) = # of accidentals from earlier in the bar +c + do 45 iv = 1 , nv + do 45 kv = 1 , nvmx(iv) + naccim(midchan(iv,kv)) = 0 +45 continue + end if +c +c Time from start of gulp to end of bar, used with forced beams +c + tglp2 = lenb0+ibar*lenb1 + if (lenb0 .gt. 0) tglp2 = tglp2-lenb1 + tglp1 = tglp2-lenbar +c +c infbmx will only be true if in xtup that is NOT in explicit forced beam. +c + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrest(ivx) = .false. + infbmx(ivx) = .false. + inxtup(ivx) = .false. + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv). The loop to 4 +c ONLY initializes each voice. +c + in = 1 + nxtup = 0 + narp = 0 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrferm(ivx) = .false. + cnn(ivx) = 1 + ivxo(in) = ivx + ipo(in) = cnn(ivx) + tnote(in) = fnote(nodur,ivx,1,nacc) + to(in) = 0. + xit(ivx) = tnote(in) +c +c Note that xit(ivx) is to END of note in voice, but it1xtup is start time. +c + if (nodur(ivx,ipo(in)) .eq. 0) then +c +c First note of xtuplet at start of bar in voice ivx. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = 0. +c +c Xtup at start of bar. If no explicit forced beam, start one, set +c signal infbmx, and save number ifbnow for use at termination. +c + if (nfb(ivx) .gt. 0) then + do 60 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c No explicit fb here; so exit loop and insert one. +c + go to 61 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit fb here; must NOT insert one +c + go to 62 + end if +60 continue + end if +61 continue +c +c If here, xtup isn't in explicit fb, so must insert one +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+ + * tglp1,t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +62 continue + if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000. + in = in+1 +4 continue +c +c Build the list: This is a manual loop starting at 5 +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iiv = 1 , nv + do 6 kv = 1 , nvmx(iiv) + iivx = ivmx(iiv,kv) + tminn = min(tmin,xit(iivx)) + if(tminn .lt. tmin-tol) then + tmin = tminn + ivx = iivx + end if +6 continue + if (abs(tmin-1000.) .lt. tol) go to 7 + ivxo(in) = ivx + cnn(ivx) = cnn(ivx)+1 + ipo(in) = cnn(ivx) + to(in) = tmin +c +c Check if this voice is done +c + tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc) + if (cnn(ivx) .eq. nn(ivx)) then + xit(ivx) = 1000. + else + xit(ivx) = xit(ivx)+tnote(in) + end if +c +c Flag xtups +c + if (nodur(ivx,cnn(ivx)) .eq. 0) then + if (.not.inxtup(ivx)) then +c +c First note of xtup, not at start of bar. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = xit(ivx)-tnote(in) +c +c (Note: can't be on last note in voice, so xit(ivx) <> 1000) +c Put xtuplet in a forced beam if not already in forced beam +c + if (nfb(ivx) .gt. 0) then + do 70 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c NO explicit bm; put one in +c + go to 71 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit bm. Don't put one +c + go to 72 + end if +70 continue + end if +71 continue +c +c If here, no explicit bm, so put one in +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+tglp1, + * t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +72 continue + else if (inxtup(ivx)) then +c +c This test is sufficient because already know nodur>0 +c + inxtup(ivx) = .false. + if (infbmx(ivx)) then +c +c Xtup is in auto-forced beam, so end it +c + t2fb(ivx,ifbnow(ivx)) = + * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1 + infbmx(ivx) = .false. + end if + end if + if (btest(irest(ivxo(in),ipo(in)),24) .or. + * btest(irest(ivxo(in),ipo(in)),30)) then +c +c For staff jumped beam, flag the first note (lowest voice) at same time. +c Later will start new notes group here. +c + inj = in + if (ivxo(in) .gt. 1) then + do 40 iin = in-1 , 1 , -1 + if (to(iin)+tol .lt. to(in)) go to 41 + if (abs(to(iin)-to(in)) .lt. tol) then + inj = iin + go to 40 + end if +40 continue + end if +41 continue + irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29) + end if + in = in+1 + go to 5 +7 continue + ntot = in-1 + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = tnote(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(a)')' Greetings from PMXB' +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +c +c Done w/ list. Loop for parsing into note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c A manual loop to set space(ib) and istop(ib) +c +9 continue + + ivx = ivxo(min(in+1,ntot)) + ip = ipo(min(in+1,ntot)) + isl = islur(ivx,ip) + if (in.eq.ntot .or. ((ivx.eq.1 .and. + * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28) +c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then +c Bits 1-13: stmgx+Tupf._) +c 14: Down fermata, was F +c 15: Trill w/o "tr", was U + * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) ) +c +c Checking for start of 2nd part of jumped beam +c + * .or. btest(irest(ivx,ip),29) ) then +c +c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; +c flow out of if-loop and into block-wrapup +c +c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered +c voice, but it wasn't first in the list at the same time. So check if +c prior notes in list have same time +c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef +c changes on last note in the list? +c + if (btest(isl,15) .and. in.lt.ntot) then + do 50 iin = in , 1 , -1 + if (tno(iin) .gt. tol) then + in = iin + islur(ivx,ip) = ibclr(islur(ivx,ip),15) + islur(ivxo(in+1),ipo(in+1)) = + * ibset(islur(ivxo(in+1),ipo(in+1)),15) + go to 51 + end if +50 continue +51 continue + end if + if (space(ib) .lt. tol) then + space(ib) = tno(in) + squez(ib) = 1. + end if + istop(ib) = in + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the group, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart and istop are good, so finalize block +c + tstart(ib) = to(istart(ib)) + if (istop(ib) .eq. ntot) go to 15 + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space and squeeze-factor for upcoming block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue + nb = ib +c +c Invert the list of places into ipl(0-7), making it easier to analyze a voice +c + do 13 in = 1 , ntot +c +c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. +c +c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) + ipl2(ivxo(in),ipo(in)) = in +13 continue +c +c Compute elemskips from start of bar to each note in the bar, for beam slopes +c + eskzb = 0. + ib = 1 + do 30 in = 1 , ntot + if (in .eq. istart(ib)) then + deskb = squez(ib)*feon(space(ib)/squez(ib)) + else if (tno(in-1) .gt. tol) then + eskzb = eskzb+deskb + end if + eskz(ivxo(in),ipo(in)) = eskzb + eskz2(ivxo(in),ipo(in)) = eskzb + if (in .eq. istop(ib)) then + eskzb = eskzb+deskb + ib = ib+1 + end if +30 continue +c +c Debug writes +c +c print* +c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) +c print*,'PMXB has now got blocks' +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, +c * in=1,ntot) +c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) +c +c +c Analyze for beams. +c + do 20 iv = 1 , nv + do 20 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + numbms(ivx) = 0 + mapfb(1) = 0 + mapfb(2) = 0 + mapfb(3) = 0 + mapfb(4) = 0 +c +c First forced beams. +c + if (nfb(ivx) .gt. 0) then +c +c tglp2 is time from start of gulp to end of current bar. +c + nfbbar = 0 + do 80 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81 + nfbbar = nfbbar+1 + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) +c +c Times from beginning of bar +c + itbb1 = int(t1fb(ivx,ifb)-tglp1+tol) + itbb2 = int(t2fb(ivx,ifb)-tglp1+tol) + do 83 ip = 1 , nn(ivx) + if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then + nip1fb = ip + do 84 ip1 = ip , nn(ivx) + inip1 = ipl2(ivx,ip1) + if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then + nip2fb = ip1 + itbb3 = itbb2-2 + go to 85 + end if +84 continue + end if +83 continue + print* + print*,'Timing problem w/ forced beams' + write(15,'(/a)')'Timing problem w/ forced beams' +85 continue + call logbeam(numnew,nip1fb,nip2fb) +c +c Set up mapfb for forced beam just logged: +c + ib1 = itbb1/2 + ib2 = itbb3/2 + ibrep = lenbar/ibmrep/2 + do 86 irep = 1 , ibmrep + ib1now = max(0,ib1-(irep-1)*ibrep) + ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep) + mapnow = 0 + do 87 ib = ib1now , ib2now + mapnow = ibset(mapnow,ib) +87 continue + mapfb(irep) = ior(mapfb(irep),mapnow) +86 continue +c +c Since we are cycling thru forced beams, for those that start with a rest and +c have height & slope adjustments, move adjustments to next note. +c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at +c start of beam +c + if (btest(irest(ivx,nip1fb),0)) then +c call setbits(ipl(ivx,nip1fb+1),6,11, +c * igetbits(ipl(ivx,nip1fb),6,11)) +c call setbits(ipl(ivx,nip1fb+1),6,17, +c * igetbits(ipl(ivx,nip1fb),6,17)) +c call setbits(islur(ivx,nip1fb+1),2,27, +c * igetbits(islur(ivx,nip1fb),2,27)) + do 88 kp = nip1fb+1 , nip2fb + call setbits(ipl(ivx,kp),6,11, + * igetbits(ipl(ivx,nip1fb),6,11)) + call setbits(ipl(ivx,kp),6,17, + * igetbits(ipl(ivx,nip1fb),6,17)) + call setbits(islur(ivx,kp),2,27, + * igetbits(islur(ivx,nip1fb),2,27)) +88 continue + end if +80 continue +81 continue +c +c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. +c Remember, makeabar is called 1/bar, and it calls findbeam once per voice. +c + if (nfbbar .gt. 0) then + nfb(ivx) = nfb(ivx)-nfbbar + do 82 ifb = 1 , nfb(ivx) + t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar) + t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar) + ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar) +82 continue + end if + end if + ifb = 0 +c +c Done with forced beam masks for this bar and voice. Now get normal beams. +c + call findbeam(ibmrep,numbms,mapfb) +20 continue + return + end + subroutine make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp, + * isbj2 + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,issig,rpndot,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer istart(80),istop(80),iaskb(nm),numbms(nm), + * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2) + character*1 ulfbq,udqq,clefq(nm),slurudq + character*8 noteq + character*79 cwrq(nm),notexq,inameq + character*20 voltxtq + common /comoct/ noctup + character*80 soutq,headrq,lowerq + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical bspend,lower,cwrest(nm),vxtup, + * isgrace,isclef,nofirst,iscln,isdot,isflag, + * isacc,isfirst,flgndb,btest,stemup,upslur, + * isgaft,isarp,isrshft,isaccs,iscacc, + * lowdot,flipend,iscwr,isdotted,beamon1(nm) + real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80), + * squez(80) + logical cwrferm,drawbm + common /comcwrf/ cwrferm(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur + * ,WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + logical secondgrace +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c Set up main ib loop within which a block (notes group) is written +c + do 25 iv = 1 , nv + do 25 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ibmcnt(ivx) = 1 + ibmcnt1(ivx) = 1 + beamon(ivx) = .false. + beamon1(ivx) = .false. + nornb(ivx) = 0 + iaskb(ivx) = 1 + vxtup(ivx) = .false. + drawbm(ivx) = .true. +25 continue + naskb = 0 + ifig(1) = 1 + ifig(2) = 1 + ixtup = 0 + bspend = .false. + iscwr = .false. + rpndot = .false. + do 16 ib = 1 , nb +c +c Check for segno +c + if (btest(iornq(1,ipo(istart(ib))),4) .and. + * ivxo(istart(ib)).eq.1) then + if (noffseg.le.-10) then + write(noteq(1:5),'(1H{,i3,1H})')noffseg + lnoten = 5 + else if (noffseg.lt.0 .or. noffseg.ge.10) then + write(noteq(1:4),'(1H{,i2,1H})')noffseg + lnoten = 4 + else + write(noteq(1:1),'(i1)')noffseg + lnoten = 1 + end if + notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9' + lnote = 15+lnoten + do 130 iv = 2 , nv + if (lnote .gt. 60) then + if (islast) write(11,'(a)')notexq(1:lnote)//'%' + notexq = sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnoten+9 + else + notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnote+lnoten+9 + end if +130 continue + if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en' + lnote = 0 + end if +c +c Check for new clefs +c + isclef = .false. + if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15)) + * then +c +c In preceding line, fl32 gave wrong result for ... .gt.0 !!! +c + do 140 in = istart(ib) , istop(ib) + if (btest(islur(ivxo(in),ipo(in)),11)) then + call wsclef(ivxo(in),ninow,clefq, + * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) + end if +140 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + isclef = .true. + end if +c +c Start a notes group. We're just gonna define every one using pnotes{n}, +c where \def\pnotes#1{\vnotes#1\elemskip} +c + soutq = sq//'pnotes{' + eonsqz = squez(ib)*feon(space(ib)/squez(ib)) + if (eonsqz .gt. 9.995) then + write(soutq(9:12),'(f4.1)')eonsqz + else if (eonsqz .gt. 0.995) then + write(soutq(9:12),'(f4.2)')eonsqz + else if (eonsqz .gt. 0.095) then + soutq = soutq(1:8)//'0.' + write(soutq(11:12),'(i2)')nint(100*eonsqz) + else + soutq = soutq(1:8)//'0.0' + write(soutq(12:12),'(i1)')nint(100*eonsqz) + end if + soutq = soutq(1:12)//'}' + lsout = 13 +c +c Check whole block, flag accidentals etc that are too close, one per *time*. +c Note about bar starts and after rpt's/boublebars: There is an afterruleskip +c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so +c (dotsfac*wheadpt) is presumed to be filled up. +c + in = istart(ib)-1 + itrpt = -1 + itsig = -1 +c +c Begin big manual loop over notes in this block; ends at 112 +c +111 in = in+1 + if (in .gt. istop(ib)) go to 112 + ip = ipo(in) + ivx = ivxo(in) + if (ivx .le. nv) then + iv = ivx + else + do 128 iv = 1 , nv + if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129 +128 continue + print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2) + print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2) + stop + end if +129 continue +c +c Call precrd here so we know how much space to add for accid's in chords +c After calling precrd, icashft>0 means there is a shifted chordal accid (incl. +c main note. +c +c To call precrd, need up-downness, so must track if in beam. +c +c Deal w/ staff-jumping beams later +c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. +c * btest(nacc(ivx,ip),21)) then +c if (.not.btest(irest(ivx,ip),24)) then + if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx) + * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then + beamon1(ivx)=.true. + end if + icashft = 0 + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. +c + if (beamon1(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)), + * .false.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .false.,icashft) + end if + end if +c +c Turn beam off? +c + if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then + beamon1(ivx) = .false. + ibmcnt1(ivx) = ibmcnt1(ivx)+1 + end if +c +c Remember, rpts & internal sigs can only come at start of (internal) block +c + isacc = iand(nacc(ivx,ip),3).gt.0 + * .and. .not.btest(nacc(ivx,ip),17) + * .and. .not.btest(ipl(ivx,ip),10) +c +c i.e., do not set for chord. Now check for "(" as ornament on main note, +c +c!!! Need to do this for chord notes too. Maybe in chkarp? +c + isaccs = isacc .or. btest(iornq(ivx,ip),0) +c +c 5/15/02 Add check for ) ornament of prior note. +c 5/16 Nope...fails when grace intervenes. +c if (ip .gt. 1) then +c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) +c end if + isarp = btest(iornq(ivx,ip),27) + iscacc = .false. + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord here; check for arpeggios and accidentals. Note accid shifts are +c not of concern here, only whether there's an accid, whick causes iscacc=.true. +c + iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and. + * .not.btest(nacc(ivx,ip),17) + call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) + end if +c +c When we get motivated, will do spacing for arpeggios here. +c + if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) + * itrpt = nint(to(in)) + issig = btest(ipl(ivx,ip),28) + if (ivx.eq.1 .and. issig) itsig = nint(to(in)) + isgrace = btest(islur(ivx,ip),4) .and. + * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31) + isgaft = .false. + if (ip .gt. 1) then + xnd = tnote(ipl2(ivx,ip-1)) + isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31) + isgrace = isgrace .or. isgaft + end if + iscln = isclef .and. btest(islur(ivx,ip),11) +c +c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd +c + isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol + if (isflag) + * isflag = .not.btest(irest(ivx,ip-1),0) + * .and. udqq(nolev(ivx,ip-1), + * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u' + if (isflag) then + do 116 ibmchk = 1 , numbms(ivx) + if (ip-1 .lt. ibm1(ivx,ibmchk)) then + go to 117 +c +c Add check for non-beamed xtuplets. May be problem with stem direction. +c +c else if (ip-1.le.ibm2(ivx,ibmchk)) then + else if (ip-1.le.ibm2(ivx,ibmchk) .and. + * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then + isflag = .false. + go to 117 + end if +116 continue + end if +117 continue +c +c If isflag, then won't need to check for dot on prev. note. +c +c 5/16/02 ??? Try using this for ) ornament. +c + isflag = isflag .or. btest(iornq(ivx,ip-1),13) + isdot = ip.gt.1 + if (isdot) isdot = isdotted(nodur,ivx,ip-1) + isrshft = ip .gt. 1 + if (isrshft) isrshft = btest(irest(ivx,ip-1),20) + if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or. + * isdot.or.btest(iornq(ivx,ip),26).or. + * btest(irest(ivx,ip),21).or.isarp.or. + * btest(irest(ivx,ip),27).or.iscacc)) go to 111 +c +c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. +c Compute pts, the total occupied space including prior notehead. +c + wheadpt1 = wheadpt*fullsize(iv) + pts = wheadpt1 +c +c Set up for possible cautionary accidental here +c + if (isaccs .or. iscacc) then + if (.not.btest(iornq(ivx,ip),31)) then + taccfac = accfac + else + taccfac = 1.4*accfac + end if + end if + if (isgrace) then + secondgrace = .false. + do 122 ig = 1 , ngrace + if (.not. isgaft) then + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123 + else if (ip .gt. 1) then + if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123 + end if +122 continue + print*,'Problem finding grace index in makeabar' + stop +123 continue +c +c wgr = distance to backspace (in headwidths), less main acc. +c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. +c spgr = total space needed (w/o main acc). +c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. +c + if (nng(ig) .eq. 1) then + wgr = grafac + if (multg(ig) .eq. 0) wgr = wgr-.4 + else + wgr = nng(ig)*emgfac + do 126 ing = 2 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +126 continue + end if + if (graspace(ig) .gt. 0.) then +c +c User-defined space before grace +c + wgr = wgr+graspace(ig) + end if + ptgr(ig) = wgr*wheadpt1 + spgr = ptgr(ig)+xb4fac*wheadpt1 +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1 + if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac + pts = pts+spgr +c +c Special check for after-grace on ip-1 and normal on ip. Must go back thru +c loop again for the normal grace. +c + if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then + if (ipg(ig+1).eq.ip) then + secondgrace = .true. + ig = ig+1 + go to 123 + end if + end if + end if + if (iscln) then + pts = pts+clefac*wheadpt1 +c +c How far to backspace when printing the clef +c + ptclef(ivx) = 0. +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) + * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1 + if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr + end if + if (isrshft) then + pts = pts+rtshfac*wheadpt1 + else if (isflag) then + pts = pts+flagfac*wheadpt1 + else if (isdot) then + pts = pts+dotfac*wheadpt1 + end if + if (abs(to(in)-itrpt) .lt. tol) then +c +c Repeat, need a little extra space +c + pts = pts+dotsfac*wheadpt1 + end if + if (isarp) then + pts = pts+arpfac*wheadpt1 + end if +c +c Add in padding space +c + pts = pts+xspfac*wheadpt1 +c +c Now done with all items needing space except accidentals, +c accidental shifts, and left-notehead-shifts, and will later +c subtract a notehead if at start of bar. +c +c Get available space in elemskips (esk) +c +c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. +c * to(in) .eq. itsig + isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or. + * abs(to(in)-itsig).lt.tol + if (isfirst) then +c +c At start of bar or after repeat sign or new signature +c +c if (to(in) .eq. itsig) then + if (abs(to(in)-itsig).lt.tol) then + esk = 0. + else + esk = fbar + end if + else +c +c Not 1st note of bar +c + esk = eskz(ivx,ip)-eskz(ivx,ip-1) + end if + if (isgrace) then +c +c Since graces can be very long, cannot assume no interference if prior +c note uses >1 noteskip. So must get elsk's back to prior note, whether or +c not it used only one noteskip. +c <>???? +c +c 10/8/05 Kluge to not zero out esk if in xtup +c + esksav = esk + if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and. +c * to(in).ne.itsig) + * abs(to(in)-itsig).gt.tol) + * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) + if (abs(esk) .lt. tol) esk = esksav + end if +c +c Done getting available elemskips. Remove headwidth if first. Must do here +c rather than earlier since check uses isfirst +c + if (isfirst) pts = pts-wheadpt1 +c +c Deal with accidental shifts and left-notehead shifts +c + if (btest(ipl(ivx,ip),10)) then +c +c In a chord +c + ptsl = 0. + if (btest(irest(ivx,ip),27)) ptsl = wheadpt1 + ptsadd = max(ptsl,icashft*.05*wheadpt1) +c +c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK +c + else +c +c Not in a chord +c + ihshft = 0 + if (isaccs) then + ihshft = igetbits(nacc(ivx,ip),7,10) +c if (ihshft .ne. 0) ihshft = max(0,64-ihshft) + if (ihshft .ne. 0) ihshft = max(0,107-ihshft) + end if +c +c Check for left-shifted main note +c + if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft) + ptsadd = ihshft*.05*wheadpt1 + end if + pts = pts+ptsadd + if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd + if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd +c +c Left-shifted, non-chord note before? +c + if (ip .gt. 1) then + if (.not.btest(ipl(ivx,ip-1),10) .and. + * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1 + end if +c +c Try big accidentals first +c + ptbneed = pts + if (isaccs .or. iscacc) then + ptbneed = ptbneed+wheadpt1*bacfac + end if + if (poenom*esk .gt. ptbneed) then +c +c Set flag for big accidental +c + if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3) + go to 99 + end if +c +c Cannot use big, so try small +c + ptsneed = pts + if (isaccs .or. iscacc) then + ptsneed = ptsneed+taccfac*wheadpt1 + end if + if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, + * esk,fixednew,scaldold,0.,.false.) +99 continue + if (btest(iornq(ivx,ip),26)) then +c +c User-defined space. Warning, "zero" may change value in addask! +c + zero = 0. + call addask(to(in),ptsneed,zero, + * fixednew,scaldold,tglp1,.true.) + end if +c +c End of big manual loop over "in" for accidental checking +c + go to 111 +112 continue +c +c End of ask analysis for this block. +c +c Adjust eskz if there are added spaces. Corrects length of xtup brackets. +c + if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom) +c +c Check for internal repeat or sig change. +c + if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then + iirpt = iand(islur(1,ipo(istart(ib))),67109216) + if (iirpt .gt. 0) then +c +c Internal repeat +c + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (iirpt .eq. 96) then + if (islast) write(11,'(a)')sq//'leftrightrepeat' + fixednew = fixednew+lrrptfac*wheadpt + else if (btest(iirpt,5)) then + if (islast) write(11,'(a)')sq//'leftrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,6)) then + if (islast) write(11,'(a)')sq//'rightrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,8)) then + if (islast) write(11,'(a)')sq//'doublebar' + else + print*,'Unexpected mid-bar repeat command R*' + call stop1() + end if + scaldold = scaldold-fbar + end if + if (btest(ipl(1,ipo(istart(ib))),28)) then +c +c Internal signature change. +c + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'//sq//'afterruleskip}%' + lnote = 0 + end if + end if + flgndb = .false. +c +c Done with start-of-block stuff. Begin main loop over voices. +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + icm = midchan(iv,kv) +c +c A rather klugey way to set flag for figure in this voice +c Must always check figbass before figchk. +c + if (figbass) then + ivf = 0 + if (ivx .eq. 1) then + ivf = 1 + else if (ivx .eq. ivxfig2) then + ivf = 2 + end if + if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0 + end if + if (ivx .gt. 1) then + if (ivx .le. nv) then + call addstr(sepsymq(iv-1),1,soutq,lsout) + else + call addstr(sq//'nextvoice',10,soutq,lsout) + end if + end if + if (ihdht.gt.0 .and. ivx.eq.nv) then +c +c Write header. First adjust height if needed to miss barno. +c + if (bar1syst .and. iline.ne.1) then + ihdht = 15+irzbnd+isnx + end if +c +c Add user-defined vertical shift +c + ihdht = ihdht+ihdvrt + lchead = lenstr(headrq,80) + notexq = sq//'zcharnote{' + write(notexq(12:13),'(i2)')ihdht + notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt ' + call addstr(notexq,34,soutq,lsout) + call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout) + ihdht = 0 + end if + if (lower .and. ivx.eq.nv) then + lclow = lenstr(lowerq,80) + call addstr(sq//'zcharnote{-6}{'// + * sq//'tempo'//sq//'kern-10pt '// + * lowerq(1:lclow)//'}',33+lclow,soutq,lsout) + lower=.false. + end if + tnow = tstart(ib) + nofirst = .true. +c +c Done setting up voice ivx for start of block ib. Loop over notes in voice. +c + do 10 jn = istart(ib), istop(ib) + if (ivxo(jn) .ne. ivx) go to 10 + ip = ipo(jn) +c +c May have problem with not initializing islhgt, so do it here +c + islhgt = 0 +c + if (nofirst) then + noctup = 0 + if (ncmid(iv,ip) .eq. 23) noctup = -2 + nofirst = .false. + end if +c +c Check for internal floating figure (before last note of group). +c +12 if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol) + * then +c +c Bypassed figure location. Backup, place fig, return. +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq, + * lsout) + go to 12 + end if + end if + end if +c +c Put in \sk if needed +c + if (to(jn) .gt. tnow+tol) then + call addstr(sq//'sk',3,soutq,lsout) + tnow = tnow+space(ib) + go to 12 + end if +c +c Check for user-defined shifts +c + if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16)) + * call putshft(ivx,.true.,soutq,lsout) +21 if (iaskb(ivx).le.naskb .and. + * tnow.gt.task(iaskb(ivx))-tol) then + if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then +c +c Insert placeholder for accidental skip +c + call addstr(sq//'ask ',9,soutq,lsout) + nasksys = nasksys+1 + wasksys(nasksys) = wask(iaskb(ivx)) + if (wask(iaskb(ivx)) .gt. 0.) then + elasksys(nasksys) = elask(iaskb(ivx)) + else +c +c This is a signal to permit negative ask's. Should really have elask>=0. +c + elasksys(nasksys) = -elask(iaskb(ivx)) + end if + end if +c +c May have skipped some task's in earlier blocks (due to void voice) +c + iaskb(ivx) = iaskb(ivx)+1 + go to 21 + end if + if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. + * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then +c +c Figure on a note. NB: later special check for late figs. +c + call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout) + end if + end if + end if +c +c Check for new clef here. +c + if (isclef .and. btest(islur(ivx,ip),11)) then +c print*,'At clef insertion, ptclef:',ptclef(iv) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{-' + if (ptclef(iv) .lt. 9.95) then + write(notexq(7:9),'(f3.1)')ptclef(iv) + lnote = 9 + else + write(notexq(7:10),'(f4.1)')ptclef(iv) + lnote = 10 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) +c print*,'Just added: ',notexq(1:lnote) + end if + call clefsym(islur(iv,ip),notexq,lnote,nclef) + call addstr(notexq,lnote,soutq,lsout) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{' + if (ptclef(iv) .lt. 9.95) then + write(notexq(6:8),'(f3.1)')ptclef(iv) + lnote = 8 + else + write(notexq(6:9),'(f4.1)')ptclef(iv) + lnote = 9 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) + end if + end if +c +c Checking for literal TeX string BEFORE starting beams!! +c + if (btest(islur(ivx,ip),16)) then + do 124 il = 1 , nlit + if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125 +124 continue + print*,'Problem finding index for literal string' + call stop1() +125 continue +c +c Write a type 1 tex string. +c + if (lenlit(il) .lt. 71) then +c +c Add normally +c + call addstr(litq(il),lenlit(il),soutq,lsout) + else +c +c Longer than 71. Write souq, Write string, start new soutq. +c + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%' + lsout = 0 + end if + end if +c +c Arpeggio on a main (non-chordal) note? +c + if (btest(iornq(ivx,ip),27)) then +c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), + call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip), + * soutq,lsout) + end if +c +c See if a beam starts here +c + 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 +c +c Not a jump start +c + call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) +c +c Shift beam start if notehead was shifted +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) + else +c +c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set +c to 0 at end of first part of jump beam +c + ivbj2 = ivx +c +c Check for xtup since we bypassed beamstrt wherein vxtup is normally set +c + if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2) + * vxtup(ivx) = .true. +c +c Since beamstrt is not called, and drawbm is normally set there, need to set +c it here. This could cause problems if someone tries a staff-jumping, +c unbarred beam, which I'll deal with when it comes up. +c + drawbm(ivx) = .true. + end if + if (ixrest(ivx) .eq. 0) then + beamon(ivx) = .true. + bspend = .true. + if (.not.btest(irest(ivx,ip),24))bspend = .true. + end if + end if +c +c Setup for chords and possible slurs in chords +c + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Just rerun precrd. Klunky, but saves +c me from tracking down errors instroduced when I moved 1st call +c forward for accidental spacing analysis. +c + if (beamon(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)), + * .true.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .true.,icashft) + end if + end if +c +c Is there slur or grace activity? +c + isgrace = btest(islur(ivx,ip),4) + if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31) +c +c isgrace if not 1st note in bar and previous note has Way-after grace. +c + if (btest(islur(ivx,ip),0) .or. isgrace) then + if (btest(islur(ivx,ip),0)) then + if (fontslur) then +c +c Call routine for non-postscript slurs +c + call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + else +c +c Postscript slurs +c + call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3, + * isdat4,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + end if + end if + if (isgrace) then +c +c Grace note. +c + iphold = ip + isgrace = .false. + if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31) + if (isgrace) iphold = iphold-1 + isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31) + * .and..not.btest(ipl(ivx,ip),29)) +c +c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace +c on current note. Do A-grace on current note, and W-grace at barend, later. +c + if (isgrace) then + call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,iphold),.false., + * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx), + * tnote(ipl2(ivx,ip)),ulq) + if (slurg(ig)) then +c +c Terminate slur started in dograce. Get direction of main note stem +c + if (.not.beamon(ivx)) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. + * tnote(ipl2(ivx,ip)).gt.63 + call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0, + * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur) + end if + end if + end if + if (btest(iornq(ivx,ip),24)) then +c +c Start slur on main note for After- or Way-after-grace. +c +c???? ndxslur = log2(33554431-listslur) + ndxslur = log2(16777215-listslur) +c +c Get note name +c + call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) +c +c Get slur direction +c + slurudq = 'u' + if (.not.beamon(ivx)) then + if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd' + else + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd' + end if +c +cc Replace ndxslur by 11-ndxslur when printing only. +c Replace ndxslur by 23-ndxslur when printing only. +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c notexq = sq//'islur'//slurudq//chax(59-ndxslur) + notexq = sq//'islur'//slurudq//chax(71-ndxslur) + * //noteq(1:lnoten) + call addstr(notexq,8+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + else + notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + end if +c call setbits(ipl(ivx,ip),4,23,ndxslur) + call setbits(ipl(ivx,ip),5,23,ndxslur) + if (btest(ipl(ivx,ip),31)) +c +c Starting slur on W-grace on THIS note. Record ndxslur. +c + * listslur = ibset(listslur,ndxslur) + end if + end if +c +c Process dynamic marks +c + if (btest(irest(ivx,ip),26)) then + call dodyn(ivx,ip, + * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip), + * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq, + * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout) + end if +c +c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. +c + if (btest(ipl(ivx,ip),10)) then +c +c Need a duration to set type of note head +c +c if (.not. vxtup(ivx)) then +c +c Clumsy test, but vxtup is not set until main note is processed. +c + if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then + nodu = nodur(ivx,ip) +c else if (mult(ivx,ip) .lt. 0) then + else if (iand(mult(ivx,ip),15)-8 .lt. 0) then + nodu = 32 + else + nodu = 16 + end if + call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout, + * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv, + * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen, + * btest(nacc(ivx,ip),27),nacc(ivx,ip)) + end if +c +c Now that chords are done, add stuff to midi file +c +c if (ismidi) call addmidi(icm,nolev(ivx,ip), + if (ismidi) call addmidi(icm, + * nolev(ivx,ip)-iTransAmt(instno(iv)), +c + * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)), + * btest(irest(ivx,ip),0),.false.) +c +c Check for breath or caesura +c + if (btest(iornq(ivx,ip),28)) then + call putcb(ivx,ip,notexq,lnote) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Check for main-note ornaments. ')' on dotted notes go in with note, not here. +c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD +c + isacc = iand(iornq(ivx,ip),4194287) .gt. 0 +c +c isacc=.true. if any ornament except segno +c + if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then +c +c If ). is only ornament, bypass. If with others, temporarirly zero the bit. +c + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (iand(iornq(ivx,ip),516079) .eq. 0) then +c +c ). is the only non-segno ornament +c + isacc = .false. + else +c +c There are other ornaments in addition +c + rpndot = .true. + iornq(ivx,ip) = ibclr(iornq(ivx,ip),13) + end if + end if + end if + if (isacc .and. .not.cwrferm(ivx)) then +c +c Check for centered whole-bar rest with fermata (bits 10 or 14). +c + if (iand(iornq(ivx,ip),17408).gt.0 + * .and. btest(irest(ivx,ip),0) .and. + * nodur(ivx,ip).eq.lenbar .and. + * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then + cwrferm(ivx) = .true. + go to 30 + end if + call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip), + * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen, + * notexq,lnote,ip,islhgt,beamon(ivx), + * btest(ipl(ivx,ip),10)) + call addstr(notexq,lnote,soutq,lsout) + end if + if (rpndot) then + iornq(ivx,ip) = ibset(iornq(ivx,ip),13) + rpndot = .false. + end if +30 continue +c +c Check for main note accidental +c + if (iand(nacc(ivx,ip),3).gt.0 .and. + * .not.btest(nacc(ivx,ip),17)) then + ihshft = igetbits(nacc(ivx,ip),7,10) + if (ihshft .ne. 0) ihshft=ihshft-107 + if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8)) +c +c Not a chord, and left-shifted main note, so left-shift accid +c + * ihshft = ihshft-20 + call doacc(ihshft,igetbits(nacc(ivx,ip),6,4), + * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip), + * btest(irest(ivx,ip),31)) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Lower dot for lower-voice notes. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest +c. 5. Flag (lowdot) is set to true +c 6. Not in an xtuplet +c + if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv + * .and. nodur(ivx,ip).ne.0) then + if (.not.btest(irest(ivx,ip),0) .and. + * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and. + * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then + if (btest(irest(ivx,ip),19)) then +c +c Note already in movdot list. Drop by 2. +c + updot(ivx,ndotmv(ivx)+1) = + * updot(ivx,ndotmv(ivx)+1)-2. + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout, + * igetbits(islur(ivx,ip),1,3)) + end if + end if + end if +c +c Check for dotted notes with moved dots +c + if (btest(irest(ivx,ip),19)) then + ndotmv(ivx) = ndotmv(ivx)+1 + call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)), + * soutq,lsout,igetbits(islur(ivx,ip),1,3)) + end if +c +c Stemlength shortening? +c + if (btest(mult(ivx,ip),27)) then + stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5 + call addstr(sq//'stemlength{',12,soutq,lsout) + write(notexq,'(f4.2)')stemshort + call addstr(notexq(1:4)//'}',5,soutq,lsout) + else if (ip .gt. 1) then + if (btest(mult(ivx,ip-1),27)) +c +c Cancel shortening. Looks like it gets automatically restored if new inst. or +c new line, so no need to worry about affecting other lines +c + * call addstr(sq//'stemlength{4.66}',17,soutq,lsout) + end if +c +c Zero out slur-height marker for raising ornaments +c + islhgt = 0 +c +c Now start with spacing notes. Is a beam start pending? +c + if (bspend .and. + * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then + if (ixrest(ivx) .eq. 4) then +c +c Special path for single note at end of otherwise beamed xtup +c + ixrest(ivx) = 0 + else + call beamn1(notexq,lnote) + end if + bspend = .false. +c +c Is a beam ending? +c + else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then + * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or. + * btest(nacc(ivx,ip),20))) then + if (bspend) then +c +c Must be a single-note ending of a jump-beam +c + bspend = .false. + end if + call beamend(notexq,lnote) + if (.not.btest(nacc(ivx,ip),20)) then + vxtup(ivx) = .false. + nornb(ivx) = 0 + ibmcnt(ivx) = ibmcnt(ivx)+1 + beamon(ivx) = .false. + end if +c +c Or if we're in the middle of a beam +c + else if (numbms(ivx).gt.0 .and. beamon(ivx)) then + call beamid(notexq,lnote) +c +c Or whole-bar rest +c + else if (btest(irest(ivx,ip),0) + * .and. nodur(ivx,ip).eq.lenbar + * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0) + * .and..not.btest(irest(ivx,ip),25) + * .and..not.btest(islur(ivx,ip),29)) then +c +c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp +c + cwrest(ivx) = .true. + iscwr = .true. + call notex(cwrq(ivx),lcwr(ivx)) + tnow = tnow+lenbar + go to 10 + else if (ixrest(ivx) .eq. 0) then +c +c Before writing note or rest, check for keyboard rest height adjustment. +c Conditions are 0. This is a non-blank rest +c 1. kbdrests = .true. +c 2. There are two voices on the staff +c 3. No user-def height adjustments have been applied (nolev<50) +cc 4. Not last note in bar +cc 5. Followed by note (add better test later) +c + if (kbdrests .and. btest(irest(ivx,ip),0) .and. + * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. +c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) +c * .and. .not.(btest(irest(ivx,ip+1),0))) then + * nolev(ivx,ip).le.50) then +c +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 + end if +2 continue +c +c Write a separate note or rest +c + call notex(notexq,lnote) + end if +c +c Right offset? This may cause trouble +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (ixrest(ivx).eq.0 .and. lnote.gt. 0) + * call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) +c +c Terminate user-defined offsets. Fix format +c + if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) + * call putshft(ivx,.false.,soutq,lsout) +c +c Deal with After- and Way-after-graces. First, if end of bar, compute space +c needed since it wasn't done during general ask-checks. If extra space is +c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. +c But will still need to add extra space as hardspace. +c + if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or. + * btest(ipl(ivx,ip),29))) then + do 77 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78 +77 continue + print*,'Problem finding grace index at "do 77"' + call stop1() +78 continue +c +c Get elemskip to end of bar. WON'T WORK IF XTUPS !! +c + esk = 0. + do 40 iib = ib , nb + if (iib .eq. ib) then + itleft = nint(to(ipl2(ivx,ip))) + else + itleft = nint(tstart(ib)) + end if + if (iib .lt. nb) then + itright = nint(tstart(iib+1)) + else + itright = lenbar + end if + esk = esk+feon(space(ib))* + * (itright-itleft)/space(ib) +40 continue + ptsavail = poenom*esk-wheadpt + if (nng(ig) .eq. 1) then + wgr = grafac + else + wgr = nng(ig)*emgfac + do 41 ing = 1 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +41 continue + end if + ptgr(ig) = wgr*wheadpt + ptsneed = (wgr+0.5)*wheadpt + ptsndg(ivx) = 0. + if (ptsavail .lt. ptsneed) then + ptsndg(ivx) = ptsneed + eskndg(ivx) = esk + if (btest(ipl(ivx,ip),31)) then +c +c Convert GW to GA +c + ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29) + end if + end if + end if +c +c Check for GA +c + if (btest(ipl(ivx,ip),29)) + * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,ip),.false., + * .false.,0,0,0,0,0,0,0.,ulq) +c +c Update running time +c + tnow = tnow+space(ib) +10 continue +c +c Have finished last note in this voice and block +c + itendb = nint(to(istop(ib))+space(ib)) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 +17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then +c +c There's at least one figure left. offnsk could be <0 +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout) + go to 17 + end if + end if +c +c Check for flag, dot, or upstem on last note of bar. +c + if (ib .eq. nb) then + ip = ipo(ipl2(ivx,nn(ivx))) + flgndv(ivx) = 0. + if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then + if (space(ib) .lt. 16.-tol) then +c +c Note in last space, smaller than a quarter note. +c + if ((.not.btest(irest(ivx,ip),0) .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') + * .or. isdotted(nodur,ivx,ip)) then +c +c Upstem non-rest, or dotted +c + if (numbms(ivx).gt.0 + * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx))) + * .and. .not.isdotted(nodur,ivx,ip)) + * then +c +c In beam and not dotted, so use smaller space +c + flgndv(ivx) = upstmfac + else + flgndv(ivx) = flagfac + end if + end if + else +c +c Last space, nonflagged (no beam) only worry dot or up +c + if (isdotted(nodur,ivx,ip)) then + flgndv(ivx) = flagfac + else if (tnote(ipl2(ivx,ip)).lt.64 .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') then +c +c Upstem on last note , non-flagged +c + flgndv(ivx) = upstmfac + end if + end if + end if +c +c Check for right-shifted chordal note +c + if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac + flgndb = flgndb .or. flgndv(ivx).gt.0. + if (ismidi) then +c +c For midi, set flags for accidentals on last note of bar. Assume they affect +c first note of next bar whether or not tied. +c Note has already been done, so next entry into addmidi is 1st in new bar. +c First do main note, then chord notes +c +c Gyrations needed to account for multi-bar tied full-bar notes? +cc Old old lbacc(icm) = iand(nacc(ivx,ip),7) +c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) +c + if (iand(nacc(ivx,ip),7) .gt. 0) then +c +c Explicit accidental on last main note in bar +c + do 55 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56 +55 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolev(ivx,ip) + jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7)) + end if +56 continue + if (btest(ipl(ivx,ip),10) .and. crdacc) then + do 57 icrd = icrd1 , icrd2 + iacc = igetbits(icrdat(icrd),3,20) + if (iacc .gt. 0) then +c +c Explicit accidental on chord note at end of bar +c + nolevc = igetbits(icrdat(icrd),7,12) + do 58 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolevc) go to 59 +58 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolevc + jaccbl(icm,naccbl(icm)) = iashft(iacc) + end if +59 continue +57 continue + end if +c if (lbacc(icm).eq.0 .and. accb4(icm)) then + do 65 kacc = 1 , naccim(icm) +c +c If naccim(icm)>0, +c possible implicit accidental from earlier in the bar. Check for prior accid +c in this bar at relevant note levels, main and chord notes. Only act if no +c explicit action from just above. Assuming any accid on last note in bar, +c either explicit or implicit, has same effect on 1st note of next bar. +c + if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66 + if (btest(ipl(ivx,ip),10)) then + do 67 icrd = icrd1 , icrd2 + if (iand(ishft(icrdat(icrd),-12),127) .eq. + * laccim(icm,kacc)) go to 66 +67 continue + end if + go to 65 +66 continue +c +c So far we know there is a main or chord note at level laccim(icm,kacc). So +c it will get a bl-accid if it didn't just already get one. +c + do 68 macc = 1 , naccbl(icm) + if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 +68 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = laccim(icm,kacc) + jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc) +65 continue + end if + end if +11 continue +c +c Close out the notes group +c + call addstr(sq//'en',3,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' +16 continue +c +c Check for way-after graces at end of bar. We could not link these to notes +c as in midbar since there is no note following grace! Also, set flag if +c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. +c + isgrace = .false. + do 75 iv = 1 , nv + nvmxsav(iv) = nvmx(iv) + do 75 kv = 1 , nvmx(iv) + ivmxsav(iv,kv) = ivmx(iv,kv) + ivx = ivmx(iv,kv) + ptsgnd = 0. + if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31)) + * .and. ptsndg(ivx).gt.0.) then + flgndb = .true. + if (ptsndg(ivx) .gt. ptsgnd) then + ptsgnd = ptsndg(ivx) + eskgnd = eskndg(ivx) + end if + end if + if (btest(ipl(ivx,nn(ivx)),31)) then +c +c This voice has a way-after grace here at end of bar +c + if (.not.isgrace) then +c +c This is the first one, so set up the string +c + isgrace = .true. + ivlast = 1 + soutq = sq//'znotes' + lsout = 7 + end if + do 76 iiv = ivlast , iv-1 + call addstr(sepsymq(iiv),1,soutq,lsout) +76 continue + ivlast = iv +c +c No need to put in 'nextvoice', even if 2 lines/staff +c + call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)), + * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true., + * .false.,0,0,0,0,0,0,0.,ulq) + end if +75 continue + if (isgrace) then + call addstr(sq//'en%',4,soutq,lsout) + if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout) + end if + lsout = 0 +c +c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest +c This has to be the only use of atnextbar +c +c if (ibar .eq. ibarmbr) then + if (ibar.eq.ibarmbr .and. islast) then +c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// +c * 'mbrest{',30,soutq,lsout) +c ndig = int(alog10(mbrest+.01))+1 +c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest +c lsout = lsout+ndig +c call addstr('}{',2,soutq,lsout) +c mtrspc = .5+xb4mbr +c xb4mbr = 0. +c if (mtrspc .eq. 0) then +c ndig = 1 +c else +c ndig = int(alog10(mtrspc+.01))+1 +c end if +c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc +c lsout = lsout+ndig +c call addstr('}0'//sq//'en}%',7,soutq,lsout) +c if (islast) write(11,'(a)')soutq(1:lsout) +c lsout = 0 +c ndig = int(alog10(mbrest-1+.01))+1 +c if (mbrest.eq.1) ndig=1 +c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') +c * sq//'advance'//sq//'barno',mbrest-1,'%' +c++ + soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes' + lsout = 22 + notexq = sq//'mbrest' + lnote = 7 + call istring(mbrest,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + mtrspc = .5+xb4mbr + xb4mbr = 0. + call istring(mtrspc,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len)//'0' + lnote = lnote+len+1 + do 62 iv = 1 , nv + call addstr(notexq,lnote,soutq,lsout) + if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout) +62 continue + call addstr(sq//'en}%',5,soutq,lsout) + write(11,'(a)')soutq(1:lsout) + lsout = 0 + if (mbrest .gt. 1) then + ndig = int(alog10(mbrest-1+.01))+1 + write(11,'(a14,i'//chax(48+ndig)//',a1)') + * sq//'advance'//sq//'barno',mbrest-1,'%' + end if + else if (iscwr) then +c +c Centered whole-bar rests +c + call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, + * soutq,lsout) + do 60 iv = 1 , nv + lnote = 0 + do 61 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (cwrest(ivx)) then + if (lnote .eq. 0) then + notexq = sq//'centerbar{' + lnote = 11 + end if + if (.not.cwrferm(ivx)) then + if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then +c +c Kluge to use new definitions for centered, stacked rests +c + if (cwrq(ivx)(2:10).eq.'liftpause' .or. + * cwrq(ivx)(2:10).eq.'liftPAuse') + * cwrq(ivx)(10:10) = 'c' + end if + notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+lcwr(ivx) + else +c +c Fermata on centered rest. Will need to fix up level. +c 12/6/07 shift it left so it's centered over rest +c +c notexq = notexq(1:lnote) +c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) +c lnote = lnote+11+lcwr(ivx) +c + notexq = notexq(1:lnote)//sq//'loffset{.39}{' + * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+26+lcwr(ivx) + cwrferm(ivx) = .false. + end if + end if +61 continue + if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1, + * soutq,lsout) + if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) +60 continue + call addstr(sq//'en}',4,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' + end if +c +c End of block for centered whole-bar rests and multi-bar rests +c +c If at end of block, save durations of last notes in bar, for possible use +c if clef changes at start of next bar +c + if (ibar .eq. nbars) then + do 63 iv = 1 , nv + do 63 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) +c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) + prevtn(ivx) = tnote(ipl2(ivx,nn(ivx))) +63 continue + end if +c +c Update time for midi. This is only used for the event track +c + if (ismidi) then + miditime = miditime+15*lenbar +c +c If pickup, write the real time signature to the event track. Cannot use +c mtrnuml since it was reset to 0, have to recompute it +c + if (lenb0 .eq. lenbar) + * call midievent('m',mtrdenl*lenb1/64,mtrdenl) + end if + return + end + subroutine makeabar() +c +c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for +c xtups, since only last note of xtup gets non-zero nodur, which +c corresponds to single note of full length of xtup. +c In this subroutine we make an ordered list of all notes in all voices. +c ilnc = list note counter +c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. +c to(ilnc) = real start time of note in PMX-units (64=whole note) +c tno(ilnc) = time to next event in the bar. +c tnote(ilnc) = actual duration of note +c Then run thru list, grouping consecutive notes into \notes groups ib. +c space(ib) = real time unit for the \notes group +c squez(ib) = factor on space to get effective space. This will be 1 if +c there is a note exactly spanning each interval of space, and +c <1 if not. +c Details: let eon = elemskips per noteskip (like length). Basic formula is +c eon = sqrt(space/2.) +c If tgovern >= space, then +c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). +c Time needed to give this eon using basic formula is +c teq = space**2/tgovern +c Factor on space to get teq is +c squez(ib) = space/tgovern +c The eon for each ib can then be computed based on time of space*squez. +c Iff squez = 1, there is a note spanning every increment in the \notes group. +c +c tnminb = minimum time span in the bar for increments spanned by notes, +c i.e., with squez=1. Use after parsing into line to decide if +c spacing needs to be "flattened" among notes groups. +c + common /comtol/ tol + parameter (nm=24,nkb=3999,maxblks=4000) + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + logical rest,firstline,newmeter,gotclef + integer cnn(nm),istart(80),istop(80) + real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600) + elskb = 0. + tnminb(ibarcnt) = 1000. + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv) +c + ilnc = 1 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cnn(ivx) = 1 + ivxo(ilnc) = ivx + ipo(ilnc) = 1 + to(ilnc) = 0. + tnote(ilnc) = fnote(nodur,ivx,1,nacc) + xit(ivx) = tnote(ilnc) + if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000. + ilnc = ilnc+1 +4 continue +c +c Build the list +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iv = 1 , nv + do 6 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + tminn = min(tmin,xit(ivx)) + if(tminn .lt. tmin) then + tmin = tminn + ivnext = ivx + end if +6 continue + if (tmin .gt. 999.) go to 7 + ivxo(ilnc) = ivnext + cnn(ivnext) = cnn(ivnext)+1 + ipo(ilnc) = cnn(ivnext) + to(ilnc) = tmin +c +c Check if this voice is done +c + tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc) + if (cnn(ivnext) .eq. nn(ivnext)) then + xit(ivnext) = 1000. + else + xit(ivnext) = xit(ivnext)+tnote(ilnc) + end if + ilnc = ilnc+1 + go to 5 +7 continue + ntot = ilnc-1 + if (ntot .gt. 600) then + call printl(' ') + call printl('Cannot have more than 600 notes per bar, stopping') + call stop1() + end if + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc) + tnote(ntot) = tno(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(tnote(in),in=1,ntot) +c +c Done w/ list. Initialize loop for building note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c Start the loop +c +9 continue + if (in .eq. ntot) then + if (space(ib) .lt. tol) then + space(ib) = tno(in) +c +c Last gap in bar is spanned by a note, so cannot need a squeeze. +c + squez(ib) = 1. + end if + istop(ib) = ntot +c +c From here flow out of this if block and into block-setup +c + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else +c +c Tentative space tno(in) is non-zero. Set squez, which will be kept (since +c it is a unique property of the particular increment starting here) : +c + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the space, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then +c +c Next increment has same space. Does it have same squez? +c + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) +c +c If it does have the same squez, loop, otherwise flow out +c + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart, istop, space, and squez are good, so close out block +c + tstart(ib) = to(istart(ib)) +c +c Compute elemskips assuming no flattening to increase min space. The formula +c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible +c flattening in pmxb), elsperns = squez*feon(space/squez) +c + elsperns = f1eon(space(ib)*squez(ib)) + if (istop(ib) .eq. ntot) then + nnsk = nint((lenbar-tstart(ib))/space(ib)) + else + nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib)) + end if + elskb = elskb+elsperns*nnsk + if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then + call catspace(space(ib),squez(ib),nnsk) + else +c +c This is the first entry for this bar +c + nnpd(nptr(ibarcnt)) = nnsk + durb(nptr(ibarcnt)) = space(ib) + sqzb(nptr(ibarcnt)) = squez(ib) + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + end if +c +c Update minimum space spanned by a note +c + if (abs(squez(ib)-1) .lt. tol) + * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib)) + if (istop(ib) .eq. ntot) go to 15 +c +c End of spatial accounting for now +c + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space for new block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue +c nb = ib +c +c Debug writes +c +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c + return + end + subroutine midievent(typeq,in1,in2) +c +c We now store "conductor" events in mmidi(numchan,.), and count bytes +c with imidi(numchan) +c + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comevent/ miditime,lasttime + character*1 typeq + idur = isetvarlen(miditime-lasttime,nbytes) + imidi(numchan) = imidi(numchan)+nbytes+1 + do 1 i = 1 , nbytes + mmidi(numchan,imidi(numchan)-i) = mod(idur,256) + idur = ishft(idur,-8) +1 continue + mmidi(numchan,imidi(numchan)) = 255 + if (typeq .eq. 't') then +c +c Tempo event. in1 = quarters per minute (integer) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+1 + mmidi(numchan,imidi(numchan)+2) = 3 + misperq = nint(60000000./in1) + do 2 i = 1 , 3 + mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256) + misperq = ishft(misperq,-8) +2 continue + imidi(numchan) = imidi(numchan)+5 + else if (typeq .eq. 'm') then +c +c Meter event. in1=numerator, in2=denom (power of 2) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+8 + mmidi(numchan,imidi(numchan)+2) = 4 + mmidi(numchan,imidi(numchan)+3) = in1 + if (in2 .gt. 0) then + mmidi(numchan,imidi(numchan)+4) = log2(in2) + else + mmidi(numchan,imidi(numchan)+4) = 0 + end if + mmidi(numchan,imidi(numchan)+5) = 24 + mmidi(numchan,imidi(numchan)+6) = 8 + imidi(numchan) = imidi(numchan)+6 + else if (typeq .eq. 'k') then +c +c Keychange event. in1 = isig +c + mmidi(numchan,imidi(numchan)+1) = 5*16+9 + mmidi(numchan,imidi(numchan)+2) = 2 + mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256) + mmidi(numchan,imidi(numchan)+4) = 0 + imidi(numchan) = imidi(numchan)+4 + else + print*,'Program flameout in midievent' + call stop1() + end if + lasttime = miditime + return + end + subroutine moveln(iuin,iuout,done) + logical done + character*129 outq + done = .false. + read(iuin,'(a)',end=1) outq + lenout = llen(outq,129) + write(iuout,'(a)') outq(1:lenout) + return +1 done = .true. + return + end + subroutine mrec1(lineq,iccount,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + function ncmid(iv,ip) + parameter (nm=24) + common /all/ mult(nm,200),jv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + if (ncc(iv) .eq. 1) then + ncmid = ncmidcc(iv,1) + else + xtime = to(ipl2(ivx,ip)) + do 1 icc = ncc(iv) , 1 , -1 + if (xtime .gt. tcc(iv,icc)-tol) then + ncmid = ncmidcc(iv,icc) + return + end if +1 continue + print*,'Problem in ncmid()' + stop + end if + end + function ncmidf(clefq) +c +c Return middle line of a clef +c + character*1 clefq +c if (clefq.eq.'t' .or. clefq.eq.'0') then +c ncmidf = 35 +c else if (clefq.eq.'s' .or. clefq.eq.'1') then +c ncmidf = 33 +c else if (clefq.eq.'m' .or. clefq.eq.'2') then +c ncmidf = 31 +c else if (clefq.eq.'a' .or. clefq.eq.'3') then +c ncmidf = 29 +c else if (clefq.eq.'n' .or. clefq.eq.'4') then +c ncmidf = 27 +c else if (clefq.eq.'r' .or. clefq.eq.'5') then +c ncmidf = 25 +c else if (clefq.eq.'f' .or. clefq.eq.'7') then +c ncmidf = 37 +c else +c ncmidf = 23 +c end if + ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 + return + end + subroutine newvoice(jv,clefq,change) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + character*1 ulfbq,clefq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical change,autofbon + nvmx(jv) = 1 + ivmx(jv,1) = jv + itsofar(jv) = 0 + nnl(jv) = 0 + nfb(jv) = 0 + if (firstgulp .or. change) then + ncmidcc(jv,1) = ncmidf(clefq) + else + ncmidcc(jv,1) = ncmidcc(jv,ncc(jv)) + end if + tcc(jv,1) = 0. + ncc(jv) = 1 + nudoff(jv) = 0 + ndotmv(jv) = 0 + do 5 j = 1 , 200 + irest(jv,j) = 0 + islur(jv,j) = 0 + ipl(jv,j) = 0 + nacc(jv,j) = 0 + iornq(jv,j) = 0 + mult(jv,j) = 0 + if (jv.le.2) isfig(jv,j) = .false. +5 continue + return + end + subroutine notefq(noteq,lnote,nolev,ncmid) +c +c Returns name of note level with octave transpositions, updates noctup. +c + common /comoct/ noctup + character*8 noteq + character*1 upcaseq,noteqt,chax + nupfroma = mod(nolev+1,7) + iname = 97+nupfroma + ioctup = (nolev+1)/7-4 + noteqt = chax(iname) + if (ncmid .eq. 23) noteqt = upcaseq(noteqt) + if (ioctup .eq. noctup) then + noteq = noteqt + lnote = 1 +c +c Must ALWAYS check if lnote=1 for use with functions requiring a blank +c + else if (ioctup .gt. noctup) then +c +c Raise octave. Encase in {} +c + write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1), + * noteqt,'}' + lnote = 3+ioctup-noctup + noctup = ioctup + else +c +c Lower octave +c + write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1), + * noteqt,'}' + lnote = 3+noctup-ioctup + noctup = ioctup + end if + return + end + subroutine notex(notexq,lnote) +c +c Returns non-beamed full note name +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig,ispoi,btest,even + character*1 udq,udqq,chax + character*4 dotq + character*2 numq + character*79 notexq + character*8 noteq + character*40 restq + common /compoi/ ispoi + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + nodu = nodur(ivx,ip) + if (.not.btest(irest(ivx,ip),0)) then + udq = udqq(nole,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) + end if +c +c Check figure level +c +c if (figbass .and. isfig(ivx,ip) +c * .and. .not.btest(irest(ivx,ip),0)) then + if (figbass .and. .not.btest(irest(ivx,ip),0) .and. + * ((ivx.eq.1.and.isfig(1,ip)) + * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then + if (udq .eq. 'u' .or. nodu.ge.64) then +c +c Upper or no stem, fnole (in noleunits) set by notehead +c + fnole = nole + else +c +c Lower stem, fnole set by bottom of stem +c + fnole = nole-stemlen + end if + zmin = fnole-ncmid(ivx,ip)+4 + if (ivx .eq. 1) then + ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin)) + else + ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin)) + end if + end if + if (.not.btest(irest(ivx,ip),0)) then + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + if (nodu .eq. 1) then + notexq =sq//'cccc'//udq//noteq(1:lnoten) + lnote = lnoten+6 + else if (nodu .eq. 2) then + notexq =sq//'ccc'//udq//noteq(1:lnoten) + lnote = lnoten+5 + else if (nodu .eq. 4) then + notexq =sq//'cc'//udq//noteq(1:lnoten) + lnote = lnoten+4 + else if (nodu .eq. 8) then + notexq =sq//'c'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 16) then + notexq =sq//'q'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 32) then + notexq =sq//'h'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 64) then + notexq =sq//'wh'//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 128) then +c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' +c lnote = lnoten+10 + notexq =sq//'breve'//noteq(1:lnoten) + lnote = lnoten+6 + else + dotq = 'p' + ldot = 1 + if (btest(iornq(ivx,ip),13)) then +c +c Dotted note with ')' ornament +c + dotq='m' + else if (btest(islur(ivx,ip),3)) then +c +c Double dot +c + dotq = 'pp' + ldot = 2 + end if + if (nodu .ge. 192) then + notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+6+ldot + else if (nodu .ge. 96) then + notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 48) then + notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 24) then + notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 12) then + notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 6) then + notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+4+ldot + ispoi = .true. + else + notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+5+ldot + ispoi = .true. + end if + if (dotq(1:1) .eq. 'm') then +c +c Need another call to the note, in case the first one has octave shifts +c + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + end if + else if (btest(islur(ivx,ip),29)) then +c +c Blank rest +c + notexq = sq//'sk' + lnote = 3 + else +c +c Non-blank rest +c + lnote = 0 + nole = mod(nole+20,100)-20 +c +c Kluge to get pause symbol for rp: +c + if (btest(islur(ivx,ip),19)) nodu = 64 + if (nodu .le. 28) then +c +c Normal rest < or = double-dotted quarter +c + lrest = 3 + if (nodu .gt. 14) then + restq =sq//'qp' + else if (nodu .gt. 7) then + restq =sq//'ds' + else if (nodu .gt. 3) then + restq =sq//'qs' + else if (nodu .gt. 1) then + restq =sq//'hs' + else + restq =sq//'qqs' + lrest = 4 + end if +c if (2**log2(nodu) .ne. nodu) then +cc +cc One or two dots on rest +cc +c restq = restq(1:3)//'p' +c lrest = 4 +c if (2*nodu .gt. 3*2**log2(nodu)) then +cc +cc Double dotted rest +cc +c restq = restq(1:4)//'p' +c lrest = 5 +c end if +c end if + notexq = restq + lnote = lrest +c +c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. +c + if (nole .ne. 0) then + if (abs(nole) .lt. 10) then + noteq = chax(48+abs(nole)) + lnoten = 1 + else + write(noteq(1:2),'(i2)')abs(nole) + lnoten = 2 + end if + if (nole .gt. 0) then + notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' + else + notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' + end if + lnote = 16+lnoten +c if (2**log2(nodu) .ne. nodu) then +cc +cc Have dot in raised rest. must put in hbox! +cc +c notexq = notexq(1:lnote)//sq//'hbox{' +c lnote = lnote+6 +c end if + notexq = notexq(1:lnote)//restq(1:lrest) + lnote = lnote+lrest +c if (2**log2(nodu) .ne. nodu) then +c notexq = notexq(1:lnote)//'}' +c lnote = lnote+1 +c end if + end if + if (2**log2(nodu) .ne. nodu) then +c +c Deal with dots (on rests shorter than half rest) +c + restq = sq//'pt' + lrest = 3 + if (2*nodu .gt. 3*2**log2(nodu)) then + restq = sq//'ppt' + lrest = 4 + end if + nole = nole+4 + raisedot = 0 +c +c Tweak dot positions for special cases +c + even = (mod(100+nole,2).eq.0) +c if (.not.even.and.nodu.gt.8.and. +c * (nole.lt.0.or.nole.gt.8)) then + if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then + raisedot = 1 + end if + if (nole.ge.10 .or. nole.le.-1) then + write(numq,'(i2)')nole + restq = restq(1:lrest)//'{'//numq//'}' + lrest = lrest+4 + else + restq = restq(1:lrest)//chax(nole+48) + lrest = lrest+1 + end if + if (raisedot.gt.0) then + restq = sq//'raise'//sq//'internote'// + * sq//'hbox{'//restq(1:lrest)//'}' + lrest = lrest+23 + end if + + + + notexq = restq(1:lrest)//notexq(1:lnote) + lnote = lnote+lrest + end if + else +c +c Half rest or longer +c + if (nole .eq. 0) then +c +c Half or longer rest is not raised or lowered +c + if (nodu .le. 56) then + notexq =sq//'hpause' + lnote = 7 + else if (nodu .le. 112) then + if (.not.btest(islur(ivx,ip),19) .or. + * btest(irest(ivx,ip),25)) then + notexq = sq//'pause' + else + notexq = sq//'pausc' + end if + lnote = 6 + else + notexq =sq//'PAuse' + lnote = 6 + end if + if (2**log2(nodu) .ne. nodu) then +c +c Dotted rest, hpause or longer +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + if (2*nodu .gt. 3*2**log2(nodu)) then +c +c Double dotted long rest +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if + end if + else +c +c Raised or lowered half or whole rest +c + if (nodu .eq. 32) then + notexq = sq//'lifthpause' + lnote = 11 + else if (nodu .eq. 48) then + notexq = sq//'lifthpausep' + lnote = 12 + else if (nodu .eq. 56) then + notexq = sq//'lifthpausepp' + lnote = 13 + else if (nodu .eq. 64) then + notexq = sq//'liftpause' + lnote = 10 + else if (nodu .eq. 96) then + notexq = sq//'liftpausep' + lnote = 11 + else if (nodu .eq. 112) then + notexq = sq//'liftpausepp' + lnote = 12 + else if (nodu .eq. 128) then + notexq = sq//'liftPAuse' + lnote = 10 + else +c +c Assume dotted double whole rest +c + notexq = sq//'liftPAusep' + lnote = 11 + end if +c +c Set up height spec +c + nole = sign(abs(nole)/2,nole) + if (nole.le.9 .and. nole.ge.0) then + noteq = chax(48+nole) + lnoten = 1 + else + noteq = '{' + if (nole .ge. -9) then + write(noteq(2:3),'(i2)')nole + lnoten = 3 + else + write(noteq(2:4),'(i3)')nole + lnoten = 4 + end if + noteq = noteq(1:lnoten)//'}' + lnoten = lnoten+1 + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + end if + end if + return + end + function ntindex(line,s2q,lenline) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q,line + character*1 chax + logical intex + ndxs2 = index(line,s2q) + ndxbs = index(line,chax(92)) + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(line,lenline) + intex = .true. + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(line(ic+1:len),s2q)+ic + else + ntindex = ndxs2 + return + end if + else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then + intex = .false. + else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92)) + * then + intex = .true. + end if +1 continue + end if + return + end + subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote) +c +c This appends to notexq e.g. '\ibbbu1' +c + common /combbm/ isbbm + logical isbbm + character*79 notexq + character*1 char1q,ulqq,chax + character*4 tempq + if (n .ge. 5) isbbm = .true. + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//chax(92)//char1q + else + notexq = chax(92)//char1q + end if + lnote = lnote+2 + do 3 im = 1 , n + notexq = notexq(1:lnote)//'b' + lnote = lnote+1 +3 continue +c +c add the number, 0 if 12 +c +c 5/25/08 Allow >12 +c +c call istring(mod(iv,12),tempq,len) + if (iv .lt. 24) then + call istring(iv,tempq,len) + else if (iv .eq. 24) then + tempq(1:1) = '0' + len = 1 + else + call printl('Sorry, too man open beams') + call stop1() + end if + notexq = notexq(1:lnote)//ulqq//tempq(1:len) + lnote = lnote+1+len + return + end + function numclef(clefq) +c +c Returns the number to be used as argument of \setclef (for MusiXTeX only) + character*1 clefq +c if (ichar(clefq) .lt. 55) then + if (ichar(clefq) .le. 55) then + numclef = ichar(clefq)-48 + if (numclef .eq. 7) numclef = 9 + else + numclef = index('tsmanrbxxf',clefq)-1 + end if + return + end + subroutine outbar(i,jlast) + character*1 chax + nfmt = log10(i+.5)+2 + if (jlast+5+nfmt .lt. 80) then + write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = jlast+5+nfmt + else + write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = 5+nfmt + end if + return + end + subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize) +cccccccccccccccccccccccccccccccccccccccccccccccc +cc cc +cc Subroutine, combine with pmxb.for +cc +cccccccccccccccccccccccccccccccccccccccccccccccc +cc +cc Need to consider X spaces in xtuplets when getting poenom, and +cc maybe fbar? +cc mx06a +cc ID numbers for voices when number of voices is reduced. +cc +cc mx03a +cc account for new fracindent for new movements. +cc +cc Known changes since pmxa. Version 1.1b (see pmxb for longer list) +cc +cc Check ID codes for slurs. +cc Version 1.24 still does not have details for spacing/positioning +cc arpeggios if there are accidentals or shifted notes or crowded scores. +cc Fix problem in 1.22 with arpeggios across multi-line staves +cc Fix problem in 1.22 with flat key signatures +cc Read setup data as strings +cc Warning for octave designation plus +/- +cc Don't pause for volta warning, +cc Macros +cc Correct fsyst to account for transposition and key changes. +cc Check for nbars > nsyst +cc +ccccccccccccccccccccccccccccccccccc + parameter (nm=24,nkb=3999,nks=125,maxblks=4000) + logical loop,usefig,isfirst,optimize + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + integer nn(nm),nodur(nm,200),ivxo(600),ipo(600), + * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600) + character*128 lnholdq + character*44 basenameq + logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt, + * stickyS + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr, + * shifton,barend + common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml, + * nodur,lenbar,iccount,nbars,itsofar,nib,nn, + * rest,lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + common /comeon/ eonk,ewmxk + logical mrecord,mplay,endmac,gotclef,cstuplet + logical novshrinktop,upslur,fontslur,WrotePsslurDefaults + common /comnvst/ novshrinktop,cstuplte + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + data wtimesig,wclef,wkeysig + * / 0.72 , 0.8 , 0.28 / + whead20 = 0.3 + if (.not.optimize) then + print* + print*,'Starting first PMX pass' + write(15,'(a)') ' Starting first PMX pass' + end if + if (isfirst) then + open(19,file='pmxaerr.dat') + write(19,'(i6)') 0 + close(19) + end if + if (.not.optimize) jprntb = 81 + macuse = 0 + ornrpt = .false. + stickyS = .false. + mrecord = .false. + mplay = .false. + lastchar = .false. + novshrinktop = .false. + cstuplet = .false. + fontslur = .true. + isligfont = .false. + fulltrans = .false. + do 42 ibarcnt = 1 , nkb + udsp(ibarcnt) = 0. + wminnh(ibarcnt) = -1. +42 continue +c +c Initialize input buffer +c + lenbuf0 = ipbuf + ipbuf = 0 + ilbuf = 1 + call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb) +c +c Set up list of instrument numbers (iv) +c + ivnow = 0 + do 13 instnow = 1 , noinst + do 14 iscount = 1 , nsperi(instnow) + ivnow = ivnow+1 + instno(ivnow) = instnow +14 continue +13 continue +c +c Save initial meter for midi +c + if (.not.isfirst .and. npages.eq.0) then + print*,'Sorry, must have npages>0 for optimization.' + call stop1() + end if + nsyout = nsyst +c +c isig1 will be changed in getnote if there is a transposition +c + isig1 = newkey(1) + if (npages .gt. nsyst) then + call printl('npages > nsyst in input. Please fix the input.') + call stop1() + end if +c +c fbar = afterruleskip/elemskip +c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt +c + fbar = 1. + wheadpt = whead20*musize + ifig = 0 + usefig = .true. + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbr1 = lenmult*mtrnuml*lenbeat + lenbr0 = nint(lenmult*xmtrnum0*lenbeat) + mtrnuml = 0 + if (lenbr0 .ne. 0) then + ibaroff = 1 + lenbar = lenbr0 + else + ibaroff = 0 + lenbar = lenbr1 + end if + ibarcnt = 0 + nptr(1) = 1 + iccount = 128 + nmovbrk = 0 + nflb = 0 + nfpb = 0 + ipagfpb(0) = 1 + isysfpb(0) = 1 + ibarflb(0) = 1 + isysflb(0) = 1 + nistaff(0) = nv-1 +c +c Check for pmx.mod +c + linesinpmxmod = 0 +c line1pmxmod = ilbuf + call getpmxmod(.true.,' ') + if (.not.isfirst .and. linesinpmxmod .gt. 0) then + print*,'Sorry, cannot optimize if there is a pmx.mod file' + call stop1() + end if +c +c Initialize for loop over lines +c + nkeys = 1 + ibrkch(1) = 1 + mbrestsav = 0 + shifton = .false. + firstline = .true. + newmeter = .false. + ihead = 0 + isheadr = .false. + gotclef = .false. + idsig = 0 + iddot = 0 + fintstf = -1. + gintstf = 1.0 + listcresc = 0 + listdecresc = 0 +30 loop = .true. + iskchb = .false. + issegno = .false. + nbars = 0 + ibarmbr = 0 +3 do 4 iv = 1 , nv + nvmx(iv) = 1 + ivmx(iv,1) = iv + itsofar(iv) = 0 + nnl(iv) = 0 + do 5 j = 1 , 200 + rest(iv,j) = .false. + nacc(iv,j) = 0. +5 continue +4 continue + iv = 1 + ivx = 1 + fbon = .false. + barend = .false. + isvolt = .false. +2 if (loop) then +c +c Within this short loop, nv voices are filled up for the duration of a block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nodur(..),rest(..). nnl will later be +c increased and things slid around as accidental skips are added. +c + call g1etnote(loop,ifig,optimize,fulltrans) + if (lastchar) go to 20 + go to 2 + end if + if (mbrestsav .gt. 0) then + call printl(' ') + call printl( + * 'You must enter the same multibar rest in ALL parts') + call stop1() + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 +c +c The following is just a signal to start a new bar when cataloging spaces +c for catspace(...) +c + nptr(ibarcnt+1) = nptr(ibarcnt) + newmb(ibarcnt) = .false. + if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true. +c +c Above is only for spacing calcs later on. Remember new meter can only occur +c at START of a new input line (ibar = 1) +c + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb) + else + if (.not.optimize) then + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + jprntb = 0 + end if + ibaroff = ibaroff-mbrest+1 + end if + if (firstline .and. lenbr0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenbr0 + else + lenbar = lenbr1 + end if + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nodur(ivx,ip) = nodur(ivx,ip+ioff) + rest(ivx,ip) = rest(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) +12 continue +11 continue + end if + do 67 iv = 1 , nv + do 67 kv = 1 , nvmx(iv) + ioff= 0 + if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1) +67 continue + call makeabar() + elsk(ibarcnt) = elskb+fbar +10 continue + newmeter = .false. + firstline = .false. + go to 30 +20 continue +c +c Vertical analysis. +c + if (npages .eq. 0) then + if (nsyst .eq. 0) then + print*,'When npages=0, must set nsyst=bars/syst, not 0' + call stop1() + end if + nsyst = (ibarcnt-1)/nsyst+1 + if (nv .eq. 1) then + nsystpp = 12 + else if (nv .eq. 2) then + nsystpp = 7 + else if (nv .eq. 3) then + nsystpp = 5 + else if (nv .eq. 4) then + nsystpp = 3 + else if (nv .le. 7) then + nsystpp = 2 + else + nsystpp = 1 + end if + npages = (nsyst-1)/nsystpp+1 + end if +c +c Check nsyst vs ibarcnt +c + if (nsyst .gt. ibarcnt) then + print* + print*,'nsyst,ibarcnt:',nsyst,ibarcnt + print*,'There are more systems than bars.' + write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt + write(15,'(a)')' There are more systems than bars.' + call stop1() + end if +c +c Set up dummy forced line & page breaks after last real one +c + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+1 + isysflb(nflb) = nsyst+1 + nfpb = nfpb+1 + ipagfpb(nfpb) = npages+1 + isysfpb(nfpb) = nsyst+1 + heightil = ptheight*4./musize + open(12,status='SCRATCH') + write(12,'(a)')basenameq(1:lbase) + write(12,*)lbase +c +c Pass to pmxb the initial signature, including effect of transposition. +c + write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait, + * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1 + write(12,*)npages,widthpt,ptheight,nsyst + iflbnow = -1 + isysb4 = 0 + do 8 ifpb = 1 , nfpb +c +c Each time thru this loop is like a single score with several pages +c + npages = ipagfpb(ifpb)-ipagfpb(ifpb-1) + nsyst = isysfpb(ifpb)-isysfpb(ifpb-1) + nomnsystp = (nsyst-1)/npages+1 + nshort = nomnsystp*npages-nsyst + do 7 ipage = 1 , npages + nsystp = nomnsystp + if (ipage .le. nshort) nsystp = nsystp-1 +c +c Last system number on this page: + isysendpg = isysb4+nsystp + nintpg = 0 + do 15 isy = isysb4+1, isysendpg + if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1 + nintpg = nintpg+nistaff(iflbnow) +15 continue + xilfrac = 0. + xiltxt = 0. + if (ipage.eq.1 .and. ihead.gt.0) then +c +c Needn't zero out ihead after printing titles if we only allow titles at top? +c + if (iand(ihead,1) .eq. 1) then + xiltxt = xiltxt+hgtin*4/musize + xilfrac = xilfrac+etait + end if + if (iand(ihead,2) .eq. 2) then + xiltxt = xiltxt+hgtti*4/musize + xilfrac = xilfrac+etatc + end if + if (iand(ihead,4) .eq. 4) then + xiltxt = xiltxt+hgtco*4/musize + xilfrac = xilfrac+etacs1 + else +c +c Use double the title-composer space if there is no composer +c + xilfrac = xilfrac+etatc + end if + end if + D = xilfrac+nsystp-1+etatop+etabot +c C = nsystp*(nv-1) + C = nintpg +c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn + xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn + if (bottreb) xN = xN-(nsystp-1)*xilbtc + if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr + if (ifig .eq. 1) then + xN = xN - nsystp*xilfig + end if + glueil = (xN-b*C)/(D+a*C) + omegaG = (b*D+a*xN)/(D+a*C) +c +c G = \interlines between systems +c omega*G = \interlines between staves of the same system +c \interstaff = 4+omega*G +c C = total number of interstaff spaces in the page +c D = omega-indep factors for scalable height = nsy-1 (intersystem glue) +c + etatop + etabot + etatxt + +c N = scaleable height (\interlignes) = height - htext - staff heights - xil +c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles +c + (nsy-1)*xiltcb for treble clef bottoms +c + nsy*xilfig for figures +c G = N/(D + omega * C) = glueil, (1) +c But (empirically) omega*G = a*G + b (2) +c with a=1.071 and b=2.714 +c Solving (1) and (2) gives +c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) +c Pass to pmxb omega*G (=\interstaff-4) +c (etatop,bot,it,tc,cx)*G as inputs to \titles +c +c glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) +c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) +c xnsttop = glueil*etatop +c xintstaff = 4+gfact*glueil +c +c Only the first page will get local adjustment now if needed, others in pmxb +c + if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then + facins = fintstf + fintstf = -1. + else +c +c gintstf = 1.0 by default, but may be changed with AI +c + facins = gintstf + end if + write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4) + ihead = 0 + isheadr = .false. + isysb4 = isysendpg +7 continue +8 continue +c +c Done with vertical, now do horizontals +c + celsk(1) = elsk(1) + do 21 ibar = 2 , ibarcnt + celsk(ibar) = celsk(ibar-1)+elsk(ibar) +21 continue + lastbar(0) = 0 + ibar1 = 1 + wmins = -1. + iflb = 1 + imovbrk = 0 + ikey = 1 +c +c Return nsyst to its *total* value +c + nsyst = isysfpb(nfpb)-1 + do 22 isyst = 1 , nsyst + if (isyst .eq. isysflb(iflb)) iflb = iflb+1 + if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then + if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1 + end if + ibarb4 = lastbar(isyst-1) + if (isyst .eq. 1) then + if (isfirst) elsstarg = celsk(ibarflb(1)-1)/ + * (isysflb(1)-1-fracindent)*(1-fracindent) + celskb4 = 0. + else + celskb4 = celsk(ibarb4) +c +c Must dimension isysmb(0:*) just so I can execute this test! +c + if (isfirst) then + if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then +c +c First syst after forced line break. There may be indentation. +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst-fracsys(imovbrk)) + * *(1-fracsys(imovbrk)) + else +c +c There is no indentation to deal with +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst) + end if + end if + end if + if (isfirst) then + diff1 = abs(elsstarg-elsk(ibarb4+1)) + do 23 ibar = ibarb4+2 , ibarcnt + diff = elsstarg-(celsk(ibar)-celskb4) + if (abs(diff) .ge. diff1) go to 24 + diff1 = abs(diff) +23 continue +24 ibar = ibar-1 + lastbar(isyst) = ibar + nbarss(isyst) = ibar-ibarb4 + else +c +c nbarss is given as an input, must compute lastbar and ibar +c + lastbar(isyst) = nbarss(isyst)+ibarb4 + ibar = lastbar(isyst) + end if +c +c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. +c + elss(isyst) = celsk(ibar)-celskb4 + write(12,'(i5)')lastbar(isyst-1)+1 +c +c Transposed sigs are isig1, newkey(2,3,...). +c + if (ikey .eq. 1) then + key1 = isig1 + else + key1 = newkey(ikey) + end if + fsyst = wclef+abs(key1)*wkeysig+2./musize + xelsk = 0. +1 if (ikey.lt.nkeys) then + if (ibrkch(ikey+1).le.lastbar(isyst)) then +c +c Add space for all key changes +c + ikey = ikey+1 + key2 = newkey(ikey) + naccs = max(abs(key2-key1),max(abs(key1),abs(key2))) + fsyst = fsyst+naccs*wkeysig +c +c Account for afterruleskips (fbar) +c + xelsk = xelsk+fbar/2 + if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey)) + * xelsk = xelsk-1. + key1 = key2 + go to 1 + end if + end if +c +c Add extra fixed space for double bar +c + if (isyst .eq. nsyst) then + fsyst = fsyst+4.5/musize + end if +c +c Add extra fixed space for initial time signature +c + if (isyst .eq. 1) then + fsyst = fsyst+wtimesig + end if +c +c Add extra fixed space for time signature changes & user-defined spaces +c + do 26 ibars = ibarb4+1 , lastbar(isyst) + if (newmb(ibars)) fsyst = fsyst+wtimesig + fsyst = fsyst+udsp(ibars)/musize +26 continue + if (isyst .eq. 1) then + wdpt = widthpt*(1-fracindent) + else + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + wdpt = widthpt*(1-fracsys(imovbrk)) + else + wdpt = widthpt + end if + end if + wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst) +c +c Checks for min spacing +c Get min allowable space +c + dtmin = 1000. + do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1 + dtmin = min(dtmin,tnminb(ibar)) + if (wminnh(ibar).ge.0.) wmins = wminnh(ibar) +45 continue + if (wmins .lt. 0) wmins = 0.3 + wminpt = (1+wmins)*0.3*musize +c +c Find max duration & # of notes for this system +c + dtmax = 0. + nns = 0 + do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + dtmax = max(dtmax,durb(iptr)) + nns = nns + nnpd(iptr) +43 continue + elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk) + if (elmin0 .ge. wminpt) then +c +c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; +c there is no need to "flatten" +c + sumelsk = elss(isyst)-fbar*nbarss(isyst) + eonk = 0. + ewmxk = 1. + else + elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns) + if (elmin1 .le. wminpt) then +c print* +c print*,'In system #',isyst,' cannot meet min. space rqmt' +c write(15,'(/a,i5,a)') +c * 'In system #',isyst,' cannot meet min. space rqmt' + eonk = 0.9 + else +c +c Find eonk by Newton method +c +c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) + call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1, + * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax, + * (wminpt-elmin0)/(elmin1-elmin0)) + eonk = min(.9,eonk) + end if + ewmxk = f1eon(dtmax)**eonk +c +c Recompute poenom! +c + sumelsk = 0 + do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + sumelsk = sumelsk + * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr)) +44 continue + end if + poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk) +c +c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 +c + if (isyst .gt. 0) then + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + fracindent = fracsys(imovbrk) + else + fracindent = 0. + end if + end if + write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst), + * sumelsk,fsyst,fracindent,eonk,ewmxk + ibar1 = ibar1+nbarss(isyst) +22 continue + rewind(12) + open(13,status='SCRATCH') + write(13,'(i5)')ifig + rewind(13) + ilbuf = 1 + ipbuf = 0 + if (.not.optimize) then + write(*,'(/,a)')' Done with first pass' + print* + write(15,'(/,a)')' Done with first pass' + write(15,'()') + end if +c +c Following syntax is needed since pmxa is called with literal argument .false. +c + if (isfirst) isfirst = .false. + return + end + subroutine pmxb(inlast,poevec,ncalls,optimize) +cccccccccccccccccccccccccc +cc +cc To Do +cc +cc Resolve disagreement in final poe for 1st system, compared with *.mx2 +cc Shift slurs on right- or left-shifted main notes (2/7/99) +cc Various end-of-input-block repeat problems (ick142.pmx). +cc Force multiplicity for un-beamed xtups. +cc Clef change at end of piece +cc Global "A" option to maximize "X" at a given time tick. +cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted +cc note. See trubl18.pmx +cc Tab character as space. +cc Clef interference with second line of music. +cc Add space for interferences between *different* lines of music? +cc Shift arpeggios, both automatic and manual. +cc Different musicsize for different instruments. +cc Spacing checks for accid's on left-shifted chord notes +cc Spacing checks for double dots +cc Allow forced line breaks w/o setting nsyst. +cc Cresc-Decresc. (Enhance MusiXTeX first?) +cc Dynamic Marks. +cc Bug with Voltas at line end (MusiXTeX problem?). +cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx +cc Stem-end slurs. +cc Allow units in indentation. +cc Make inline TeX more context sensitive. +cc Werner's 4/2/98 problem with "o?" +cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. +cc converts e.g. "r2db" into "r2d", which might be wrong. +cc Werner's generalsignature problem with Key change and new transposition. +cc (wibug8.pmx) +cc Unequal xtuplets +cc Print both sets of bar #'s in tex file. +cc Make barlines invisible \def\xbar{\empty} , fix fbar. +cc Auto-tie slurs 'At' +cc Forced line break anywhere (e.g. at a mid-bar repeat). +cc Clef change at very start of file. +cc Tighten test for M as macro terminator. +cc Fix title so not separate limit on author length + composer length. +cc Arpeggios in xtups. +cc +cc mx10b +cc Option for instrument name at top center. Last item in P command: +cc P[n]c text is instrument name (use in parts) +cc P[n]cstuff text is stuff (up to 1st blank) +cc P[n]c"stuff with spaces" text is stuff with spaces +cc +cc Post version 1.43 +cc Reduced space rqmt for multiplicity-0 graces (no flag) +cc Removed last sepsym in centered whole-bar rests, fixes volta height bug. +cc +cc Version 1.43 +cc Fix spacing for end-of-line signature change. +cc Adjust left-shift of grace group for shifted accidentals. +cc Put in extra space for left-shifted accidentals. +cc Fix bug with dot-shift before accid-shift on chord note. +cc Space-check for right-shifted main notes. +cc Enable forcing stem direction of single notes in non-beamed xtups. +cc Disallow clef change after last note before end of input block (pmxa) +cc Print meter change before page break +cc increase length of strings for \titles macro +cc version 1.42 +cc Loosen up input syntax for "X" commands. Subroutine getx() +cc "B" and "P" in "X" commands +cc mx09b +cc Allow multiple rests at start of xtup +cc Add 64th rest +cc Fix xtup numbers over rests. (subroutine levrn) +cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. +cc c za / ( c a ... +cc Allow double dots to be shifted. +cc Fix spacing with double dotted notes; permit splitting small note. +cc Fix \dotted printout so it works with old compiler +cc mx08b +cc Automatic spaces if needed for shifted accidentals. +cc Some Dynamics +cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) +cc version 1.41 +cc Allow ":" as last char of path name +cc Dotted slurs "sb" +cc Continue bar numbering at movement break "L[integer]Mc" +cc mx07b +cc Whole-bar rests with double lines of music. Fixed all options ? +cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. +cc Option to suppress centering full-bar rests. "o" +cc mx06b +cc Shift accid on left-shifted chord note. +cc Rest as first note of xtup. +cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt +cc Allow Rb for single bar at movemnet break or end of piece. (islur(25)) +cc Change # of inst at a movement break. noinst is total # and must be used +cc in 1st movement. ninow is current. nspern(1,...,ninow) is current +cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to +cc reprint names in parindent at a movement break. Default is .false. +cc unless ninow changes, then .true. But can force either with r+/- as +cc option in 'M' +cc mx04b +cc Double-dotted notes, separate+beamed, main+chord, still no extra space. +cc ??? Don't shift slur ends on whole notes. +cc (pmxa) Write line number of error in pmxaerr.dat +cc mx02b +cc Admit "RD" before "/" (search for "rptfq2:" ) +cc In doslur, for multi-line staves, single notes, check forced stem dir'n +cc before setting stemup (used to set horiz offset). +ccccccccccccccccccccccccccccccc + parameter (nm=24,nks=125,mv=24576,maxblks=4000) +c +c FYI /all/ differs in appearance in function ncmid +c + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) +ccccccccccccc +cc islur cc +ccccccccccccc +c bit meaning +c 0 slur activity on this note +c 1 t-slur here. +c 2 force 0-slope beam starting on this note +c 3 Double dotted note! +c 4 grace before main note +c 5 left repeat +c 6 right repeat +c 7 start Volta +c 8 doublebar +c 9 end Volta +c 10 on=>endvoltabox +c 11 on=>clefchange +c 12-14 0=>treble, ... , 6=>bass +c 15 on=> start new block for clef change (maybe diff. voice) +c 16 literal TeX string +c 17 1=up, 0=down stem for single note (override) See bit 30! +c 18 if on, prohibit beaming +c 19 if on, full bar rest as pause +c 20 Beam multiplicity down-up +c 21 Forced multiplicity for any beam including xtups +c 22-24 Value of forced multiplicity +c 25 single barline at movement break +c 26 doubleBAR (see bits 5,6,8) +c 27-28 Forced beam fine-tune height (1 to 3) +c 29 Blank rest +c 30 If on, get stem dir'n from bit 17 +c 31 If on, suppress printing number with xtuplet starting here +ccccccccccccc +cc ipl cc +ccccccccccccc +cc 0-7 Location in list [0,200] +c 0-7 Unused +c 8 left offset main note one headwidth +c 9 right offset main note one headwidth +c 10 chord present? +c 11-16 Forced beam height adjustment (-30 to +30) +c 17-22 Forced beam slope adjustment (-30 to +30) +c 23-26 Slur index for Way-after grace. Inserted when slur is started. +cc 27 Unused? +c 27 5th bit for slur index for Way-after grace (100712) +c 28 key change: only in voice 1 +c 29 Grace after main note. (Type A) +c 30 In forced beam. Signals need to check beam heights +c 31 Grace way after main note. (stretch to next note, type W) +ccccccccccccc +cc iornq cc +ccccccccccccc +c 0 Ornament "(". Was user-defined horizontal slur shift on this note +c until 9/24/97; changed that to irest(21) +c 1-13 stmgx+Tupf._) +c 14 Down fermata, was F +c 15 Trill w/o "tr", was U +c 16-18 Editorial s,f,n +c 19-20 >^ +c 21 "?" for editorial accid, w/ or w/o s,f,n +c 22 Set if ihornb governs ornament height. Same in icrdorn. +c 23 Set in getorn if ANY note at time of this main note has ornament. +c This is ONLY used in beamstrt to signal whether to do more +c tests for whether ihornb is needed. (ihornb is only needed +c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) +c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. +c 24 Slur on after or way-after grace. Use as signal to START slur. +c 25 Tweak orn ht. Same in icrdorn for chord note +c 26 Insert user-defined space before this note (was 22) +c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord +c 28 caesura or breath +c 29 blank barline (must be iv=1) (would have used islur but no room) +c 30 "Look-left" option for keyboard rest +c 31 Set if any note (main or chord) has cautionary accid, for space checks +ccccccccccccc +cc irest cc +ccccccccccccc +c 0 rest=1, no rest = 0 +c 1 There will be a vertical shift for number of this xtup +c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' +c 7 There is a horizontal shift for xtup number +c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 +c 14 Flip up/down-ness of xtup number +c 15 Single-voice, single note shift X(...)[p]S +c 16 Start single-voice, multinote shift with this note X(...)[p]: +c 17 End single-voice, multinote shift after this note. Enter symbol +c after note. X: +c 18 User-defined hardspace after last note of bar, *after* this note. +c Value still stored in udoff(ivx,nudoff(ivx)), not with other +c hardspaces in udsp, to avoid confusion with time checks. +c 19 Move the dot. Data stored in ndotmv,updot,rtdot +c 20 Set if right-shifted main or chord note here. Use for space checks. +c 21 User-defined hardspace in xtup +c 22 User-defined slur shift horizontal slur shift. +c 23 Set on last note before staff-jumping a beam. +c 24 Set on first note after staff-jumping a beam +c 25 Suppress rest centering. "ro" +c 26 Dynamic on this note +c 27 Set if left-shifted main or chord note here. Use for space checks. +c 28 Set if xtup starts on this note. +c 29 Set on lowest-voice note at same time as 1st note after jump-beam. +c 30 Set on note after end of jump-beam segment, to force new note group +c 31 Flag for cautionary accidental +ccccccccccccc +cc nacc cc +ccccccccccccc +c 0-1 0=no accid, 1=fl, 2=sh, 3=na +c 2 double +c 3 big +c 4-9 vertshift-32 +c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) +c 17 Midi-only accidental +c 18 2:1 xtup +c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. +c 20 Set on last note of each seg except last seg of single-slope beam. +c 21 Set on 1st note of each seg except 1st seg of single-slope beam. +c 22-26 If .ne.0, printed xtup number for xtup starting on this note. +c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase +c multiplicity by 1 +c 28 Set on main note of chord if accidentals are ordered. +c 29 Tag for chordal accidental shift...means add to autoshifts. +c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. +c If upstem|downstem, main is upper|lower member of 2nd +c Action is to interchange pitches only when notes are placed. +ccccccccccccc +cc mult cc +ccccccccccccc +c 0-3 Multiplicity+8 (mult= # of flags) +c 4 Set if slope adjustment for xtup bracket +c 5-9 16+slope adjustment +c 27 Stemlength override +c 28-30 New stem length. +ccccccccccccc +cc isdat1 cc +ccccccccccccc +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +ccccccccccccc +cc isdat2 cc +ccccccccccccc +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted slur +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +ccccccccccccc +cc isdat3 cc +ccccccccccccc +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +ccccccccccccc +cc isdat4 cc Set these all at turn-on using s option +ccccccccccccc +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +ccccccccccccc +c icrdat c +ccccccccccccc +c 0-7 ip within voice +c 8-11 ivx (together with 28th bit) +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Flag for cautionary accidental on chord note +ccccccccccccc +c icrdot c: +ccccccccccccc +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c +cccccccccccccccccccccccccccccccc + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk, + * isfig,rptnd1,rptprev + logical loop,lastchar,slint,svolta,evolta,onvolt, + * cwrest(nm),islast,inlast,optimize + integer istop(80),numbms(nm),istart(80) + real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks), + * tstart(80),squez(80) + character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq + character*79 notexq,inameq + character*40 pathnameq + character*44 basenameq + character*24 fmtq + character*20 voltxtq + character*120 instrq,titleq,compoq + common /comlast/ islast,usevshrink + logical usevshrink,stickyS,OptLineBreakTies,autofbon + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /comstart/ facmtr + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /combeam/ ibmtyp + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comas3/ ask(2500),iask,topmods + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2, + * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq,lnholdq + logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend, + * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb, + * btest,sluron,setis,nobar1 + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /compoi/ ispoi + common /combc/ bcspec + common /comeon/ eonk,ewmxk + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comhsp/ hpttot(176) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /commus/ musize,whead20 + common /comtol/ tol + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize, + * ismbr,putmbr + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comcb/ nbc,ibcdata(36) + common /comclefq/ clefq + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /combibarcnt/ ibarcnt + if (.not.optimize) then + print* + print*,'Starting second PMX pass' + print* + write(15,'(a)')'Starting second PMX pass' + end if + ncalls = ncalls+1 + islast = inlast + macuse = 0 + isyscnt = 0 + stemmax = 8.2 + stemmin = 3.9 + stemlen = 6.0 + sq = chax(92) + bcspec = .true. + topmods = .false. + ismbr = .false. + read(12,'(a)')basenameq + read(12,*)lbase + read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop, + * etabot,inbothd,inhnoh,isig + ilbuf = 1 + ipbuf = 0 + call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0, + * npages,nsyst,musicsize,fracindent,istype0,inameq, + * clefq,sepsymq,pathnameq,lpath,isig0) + if (ismidi) then +c +c Initial key signature and meter for pickup bar +c + call midievent('k',isig,0) + if (xmtrnum0 .gt. tol) then +c +c We have a pickup. Some tricky stuff to get a meter: +c + xntrial = xmtrnum0 + do 5 ip2 = 0 , 5 + if (abs(mod(xntrial,1.)) .lt. tol) go to 6 + xntrial = xntrial*2 +5 continue + print*,'Problem finding meter for pickup bar' + xntrial = 1. + ip2 = 0 +6 continue + call midievent('m',nint(xntrial),2**ip2*mtrdenl) + else +c +c No pickup, enter the starting meter +c + call midievent('m',mtrnuml,mtrdenl) + end if + end if +c +c Set musicsize from value passed in common, due to possible reset by S[n]m16 +c + musicsize = musize + read(12,*)npages,widthpt,height,nsyst, + * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto +c +c If default width ever changes, must adjust this stmt. +c + slfac1 = 0.00569*524./widthpt + figbass = .false. + read(13,*)ifig + if (ifig .eq. 1) then + figbass = .true. + open(14,status='SCRATCH') + write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq// + * 'sysno by 1'//sq//'ifcase'//sq//'sysno%' + end if + lastchar = .false. + ibcoff = 0 + if (xmtrnum0 .gt. 0.) ibcoff = -1 + open(11,status='SCRATCH') +c +c vshrink for the first page is calculated in topfile, +c and if true set interstaff=10. vshrink affects Titles. +c Must also save vshrink for page ending. +c + call topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur) +c +c ninow is working value of # of instruments. noinst is max #, and # at start. +c + ninow = noinst +c +c Save original printed meter in case movement breaks +c + movnmp = mtrnmp + movdnp = mtrdnp +c + if (islast .and. figbass .and. musicsize.eq.16) + * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%' +c + if (islast .and. isligfont) then + if (musicsize .eq. 16) then + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%' + else + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%' + end if + end if + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenb1 = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenb1 = lenb1*2 + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + lenb0 = nint(xmtrnum0*lenbeat) + if (mtrdenl .eq. 2) lenb0 = lenb0*2 + if (lenb0 .ne. 0) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1' + lenbar = lenb0 + else + lenbar = lenb1 + end if +c +c Initialize full-program variables +c + fixednew = 0. + scaldold = 0. + fintstf = -1. + gintstf = 1. + nasksys = 0 + ibarcnt = 0 + iline = 0 + movbrk = 0 + isystpg = 0 + ipage = 1 + iccount = 128 + iask = 0 + nhstot = 0 + nb = 1 + if (.not.optimize) jprntb = 81 + idsig = 0 +c +c Next 5 are raise-barno parameters. irzbnd is integer part of default level. +c + irzbnd = 3 + if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4 + is1n1 = 0 + isnx = 0 + SlurCurve = 0. +c +c 111109 Made global rather than per gulp +c + ndyn = 0 + ispoi = .false. + slint = .false. + lrptpend = .false. + rptnd1 = .false. + rptfq2 = 'E' + rptprev = .false. + onvolt = .false. + flgndb = .false. + fbon = .false. + shifton = .false. + ornrpt = .false. + setis = .false. + lowdot = .false. + rename = .false. + nobar1 = .false. + equalize = .false. + usevshrink = .true. + WrotePsslurDefaults = .false. + OptLineBreakTies = .false. + HeaderSpecial = .false. +c +c vshrink is initialized in topfile +c + stickyS = .false. +c +c ixrest = 1 or 2 if xtup has started with a rest +c + do 1 ivx = 1 , nm + ixrest(ivx) = 0 + fullsize(ivx) = 1. +c +c Set legacy note level to middle c as default +c + ndlev(ivx,1) = 29 + ndlev(ivx,2) = 29 +1 continue + npreslur = 0 + nhssys = 0 + listslur = 0 + do 31 i = 1 , 202 + isdat1(i) = 0 + isdat2(i) = 0 +31 continue + nsdat = 0 +c +c Initialize flag for figures in any other voice than 1 +c + ivxfig2 = 0 +c +c Initialize for loop over gulps +c + firstgulp = .true. +c +c Start a gulp +c +30 loop = .true. + notcrd = .true. + isbjmp = .false. + isbj2 = .false. + autofbon = .false. + tautofb = 0. + nbars = 0 + nfigs(1) = 0 + nfigs(2) = 0 + ngrace = 0 + ntrill = 0 + ncrd = 0 + nudorn = 0 + nlit = 0 + nvolt = 0 + ibarmbr = 0 + nudsp = 0 +c ndyn = 0 ! 111109 + ntxtdyn = 0 + nbc = 0 + NumArpShift = 0 + do 3 i = 1 , 37 + graspace(i) = 0. +3 continue +c +c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. +c and also if nv increases in an 'M' directive. +c + do 4 iv = 1 , nv + call newvoice(iv,clefq(iv),.false.) +4 continue +c +c Check if endsymbol was set earlier +c + if (rptnd1) then + rptnd1 = .false. + rptfq2 = rptfq1 + else +c +c Only use if movbrk>0, to signal default ('RD') +c + rptfq2 = 'E' + end if + iv = 1 + ivx = 1 +2 if (loop) then +c +c Within this loop, nv voices are filled up for the duration of the block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). +c nbars is for this input block. +c Only at the beginning of an input block will there be a possible mtr change, +c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) +c + call getnote(loop) + if (lastchar) go to 40 + go to 2 + end if +c +c Finished an input block (gulp). +c + if (ismidi) then +c +c Put rests into midi array for 2nd lines that were not used in this gulp. +c + do 60 iv = 1 , nv + if (twoline(iv) .and. nvmx(iv).eq.1) then + if (firstgulp .and. lenb0.ne.0) then + call addmidi(midchan(iv,2),0,0,0, + * (nbars-1.)*lenbar+lenb0,.true.,.false.) + else + call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true., + * .false.) + end if + end if +60 continue + end if + nvolt = 0 + do 28 iv = 1 , nm + nudoff(iv) = 0 + ndotmv(iv) = 0 +28 continue +c +c Put stuff at top of p.1. Must wait until now to have read title info. +c + if (ibarcnt .eq. 0) then + call puttitle(inhnoh,xnsttop(ipage), + * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 + bar1syst = ibarcnt .eq. iauto + ndig = max(0,int(log10(.001+ibarcnt+ibcoff))) + if (islast) + * write(11,'(a11,i'//chax(50+ndig)//')') + * '% Bar count',ibarcnt+ibcoff + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb) + else + if (.not.optimize) then + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + jprntb = 0 + end if + ibcoff = ibcoff+mbrest-1 + if (ibar.eq.1 .and. firstgulp .and. + * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize +c +c The above may be he only case where the space-before option is used in \mbrest +c + end if +c +c Move the read to after end-of-bar hardspace checks, so we get right poenom +c at end of a line. +c if (bar1syst) read(12,*) poenom +c +c Check for clef at start of bar. No slide yet. Also flags at end of prev. +c bar. This block is run at the start of every bar. May fail for flag at +c end of last bar. To account for necc. hardspaces, compute and store +c nhssys = # of hard spaces for this system +c hesk(nhssys) = elemskips avialable +c hpts(nhssys) = hard points needed, including notehead +c Here, merely insert placeholder into output. Later, when poe is computed, +c compute additional pts and store them in hpttot(1...nhstot). Finally in +c subroutine askfig, write true pts where placeholders are. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(1,ibar-1) + clchb = btest(islur(1,ioff+1),15) + putmbr = .false. + if (ismbr) then + if (clchb) then +c +c Clef change and multi-bar rest coming up. Kluge to get space at end of rest. +c + write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest' + * //sq//'def'//sq//'mbrest#1#2#3{%' + write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55, + * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%' + end if + ismbr = .false. + putmbr = .true. + end if + if (ibar .eq. ibarmbr) ismbr = .true. +c +c Set flag here so at start of next bar, if there's a clef change, can add space +c after the mbr with the above kluge +c + if (.not.(clchb .or. flgndb)) go to 23 +c +c Must check available space +c + ptsndb = 0. +c +c Zero out block signal +c + if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15) +c +c In this loop, we determine how much hardspace is needed (if any) +c 9/7/97 Note that for last bar in input block, if number of lines of +c music decreases in new block, highest numbered ones won't be checked +c since the loop below covers the new nvmx(iv), not necessarily the old +c one. +c 4/18/98 Apparently nmxsav was a solution to the above problem +c + do 16 iv = 1 , nv + do 16 kv = 1 , nvmxsav(iv) + ivx = ivmxsav(iv,kv) + ptsndv = flgndv(ivx)*wheadpt + ioff = 0 + if (ibar .gt. 1) then + ioff = nib(ivx,ibar-1) + ip = ioff + if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2) +c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) + prevtn(ivx) = tnote(ipl2(ivx,ip)) +c +c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. +c + end if +c +c Only allow clef changes when ivx <= nv +c + if (ivx .le. nv) then + clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11) + if (clchv(iv)) then +c +c Clef change in this voice. Turn off signal. Get space avail. +c + islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11) + if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv = + * ptsndv+clefend*wheadpt + end if + end if + ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac) +16 continue +c +c ???? where is nb set??? nb probably in left over from makeabar +c + esk = feon(space(nb)*squez(nb)) + ptsdflt = esk*poenom-wheadpt +c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then + if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0 + * .and. .not.putmbr) then +c +c Must ADD hardspace! So put in a placeholder, and store params for later. +c + if (islast) write(11,'(a)')sq//'xardspace{ pt}%' + nhssys = nhssys+1 + if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then + hesk(nhssys) = esk + hpts(nhssys) = ptsndb+wheadpt + else + hesk(nhssys) = eskgnd + hpts(nhssys) = ptsgnd+wheadpt + end if + fixednew = fixednew+hpts(nhssys) + scaldold = scaldold+hesk(nhssys) + end if + if (clchb) then + do 17 iv = 1 , nv + if (clchv(iv)) then + notexq = sq//'znotes' + lnote = 7 + do 24 iiv = 2 , iv + notexq = notexq(1:lnote)//sepsymq(iiv-1) + lnote = lnote+1 +24 continue +c +c Recompute ioff since it will vary from voice to voice +c + if (ibar .eq. 1) then + ioff = 0 + else + ioff = nib(iv,ibar-1) + end if +c +c Must call clefsym to get nclef, even if there is a movement break +c + call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef) + if (movbrk.eq.0 .and. + * islast) + * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' + call wsclef(iv,ninow,clefq,nclef) + end if +17 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + end if +23 continue +c +c End of loop for end-of-bar hardspaces and non-movbrk clef symbol. +c + if (bar1syst) then + read(12,*) poenom + end if +c +c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) +c + if (ibar .eq. 1) then + islnow = islur(1,1) + iornqnow = iornq(1,1) + else + islnow = islur(1,nib(1,ibar-1)+1) + iornqnow = iornq(1,nib(1,ibar-1)+1) + end if +c +c Check for R-symbols set at end of prior input block +c + if (movbrk.eq.0 .and. rptfq2.ne.'E') then + if (rptfq2 .eq. 'D') then + islnow = ibset(islnow,26) + else if (rptfq2 .eq. 'r') then + islnow = ibset(islnow,6) + else if (rptfq2 .eq. 'd') then + islnow = ibset(islnow,8) + else if (rptfq2 .eq. 'b') then + islnow = ibset(islnow,25) + else + print* + print*,'Illegal symbol with "R" at end of input block:', + * rptfq2 + call stop1() + end if + rptfq2 = 'E' + end if + if (iand(islnow,352) .ne. 0) then +c +c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set +c + lrpt = btest(islnow,5) + rrpt = btest(islnow,6) + lrptpend = lrpt.and.bar1syst + if (lrpt .and. .not.lrptpend) then + if (rrpt) then + if (islast) write(11,'(a)')sq//'setleftrightrepeat' + fixednew = fixednew+wheadpt*lrrptfac-0.4 + else + if (islast) write(11,'(a)')sq//'setleftrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + end if + else if (rrpt) then + if (islast) write(11,'(a)')sq//'setrightrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + else if (btest(islnow,8)) then + if (islast) write(11,'(a)')sq//'setdoublebar' + fixednew = fixednew+wheadpt*dbarfac-0.4 + end if + else if (btest(islnow,26)) then +c +c doubleBAR +c + if (islast) write(11,'(a)')sq//'setdoubleBAR' + fixednew = fixednew+wheadpt*ddbarfac-0.4 + else if (btest(iornqnow,29)) then +c +c no bar line +c +c-- if (islast) write(11,'(a)')sq//'setzalaligne' +c++ + if (islast) then + if (movbrk .eq. 0) then + write(11,'(a)')sq//'setzalaligne' + else +c +c Encountered "Rz" at start of input block at start of new movement, Must +c use newmovement macro with arg 4 rather than setzalaligne, since former +c already redefines stoppiece. +c + rptfq2 = 'z' + end if + end if +c++ + fixednew = fixednew-0.4 + end if +c +c 1st and 2nd endings +c + svolta = btest(islnow,7) + evolta = btest(islnow,9) + if (evolta) then + if (btest(islnow,10)) then + if (islast) write(11,'(a)')sq//'endvoltabox' + else + if (islast) write(11,'(a)')sq//'endvolta' + end if + onvolt = .false. + end if + if (svolta) then + nvolt = nvolt+1 + lvoltxt = index(voltxtq(nvolt),' ')-1 + if (lvoltxt .eq. 1) then + if (islast) write(11,'(a)')sq//'Setvolta' + * //voltxtq(nvolt)(1:1)//'%' + else + if (islast) write(11,'(a)')sq//'Setvolta'//'{'// + * voltxtq(nvolt)(1:lvoltxt)//'}%' + end if + onvolt = .true. + end if + if (ibar .gt. 1) then + ipnow = nib(1,ibar-1)+1 + else + ipnow = 1 + end if + iplnow = ipl(1,ipnow) + if (bar1syst) then +c +c If listslur>0, then there is at least one slur or tie carried over the break +c + ispstie = .false. + if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0 + * .and. islast) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat, + * ispstie,sepsymq) + iline = iline+1 +c +c End an old system, Start a new system +c + if (iline .ne. 1) then +c +c Not first line. +c Get corrected poe = points/elemskip for *previous* system +c + wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + isyscnt = isyscnt+1 + poevec(isyscnt) = poe +c +c Transfer data for system into global arrays to hold until very end +c + do 9 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) +c +c Only admit negative ask if it was user-defined space, signalled by elask<=0. +c + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +9 continue + do 25 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +25 continue +c +c Reset counters for new system +c + scaldold = 0. + fixednew = 0. + nasksys = 0 + nhssys = 0 + end if +c +c End of if block for first bar of non-first system. Still 1st bar, any system +c + if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%' + isystpg = isystpg+1 +c +c Try moving the next stmt way down, to fix a bug and get \eject printed at +c end of single-system page. +c if (isystpg .eq. nsystp(ipage)) isystpg = 0 + read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk + if (iline .gt. 1) fracindent=frac + if (figbass) then + ifigdr(1,iline) = 4 + ifigdr(2,iline) = 4 + end if + slfac = slfac1*musicsize*elsktot + if (iline .ne. 1) then +c +c For the line just _finished_, put figdrop in separate file. +c + if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)') + * sq//'figdrop=',ifigdr(1,iline-1), + * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%' +c +c Check slurs in top staff for interference w/ barno. Only check when +c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS +c keep track of ons and offs when |isig|<=3. +c + ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1 + isnx = 0 + if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then +c +c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 +c Look for termination in remainder of this input block. If not found, +c just use is1n1. Remember, haven't slid down yet. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1) + do 50 isdat = 1 , nsdat + if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv)) + * .and. .not.btest(isdat1(isdat),11) + * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then +c +c Found slur ending. Just check note height, can't do fine adjustments. +c +c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) + is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19)) + go to 51 + end if +50 continue +c +c If exiting loop normally, did not find end of slur. c'est la vie. +c +51 continue + isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd) + if (isnx .gt. 0) then +c +c AHA! Slur likely to interfere with barno. +c +c Modified 090525 to use \bnrs +c + slint = .true. + fmtq = '(a16,i1,a14)' + if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)' + if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{', + * irzbnd+isnx,'.5'//sq//'internote}%' +c if (islast) then +c if (isnx .le. 9) then +c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' +c else +c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' +c end if +c end if +c + end if + end if + if (movbrk .gt. 0) then +c +c movbrk = 0 +c Move the reset down, so can use movbrk>0 to stop extra meter prints. +c +c New movement. Redefine stoppiece, contpiece. These will be called either +c explicitly or as part of alaligne. +c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. +c This is passed to \newmovement. +c + if (rptfq2 .eq. 'E') rptfq2 = 'D' + indsym = index('Ddrbz',rptfq2)-1 + rptfq2 = 'E' +c +c Also check for Rd or Rr set the normal way +c + if (btest(islnow,8)) then + indsym = 1 + else if (btest(islnow,6)) then + indsym = 2 + end if + if (indsym .lt. 0) then + print* + print*,'Illegal end symbol before "/"' + call stop1() + end if +c +c Check for continuation (no bar number reset) +c + if (islast.and. + * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1' + * //sq//'startbarno'//sq//'barno%' + 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 +c +c Change generalmeter if necessary +c + if (islast) call wgmeter(mtrnmp,mtrdnp) +c +c (Moved all name-writing to getnote, right when 'M' is detected) +c + if (btest(iplnow,28)) then +c +c Key signature at movement break +c + iplnow = ibclr(iplnow,28) + if (isig .gt. 0) then + if (islast) write(11,'(a18,i1,a2)') + * sq//'generalsignature{',isig,'}%' + else + if (islast) write(11,'(a18,i2,a2)') + * sq//'generalsignature{',isig,'}%' + end if + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + end if + if (parmov .ge. -.1) then +c +c Resent paragraph indentation +c + ipi = parmov*widthpt+.1 + if (ipi .lt. 10) then + if (islast) write(11,'(a11,i1,a2)') + * sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + if (islast) + * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + if (islast) + * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + end if + end if + if (isystpg .eq. 1) then +c +c First line on a page (not 1st page, still first bar). Tidy up old page +c then eject. +c +c Removed this 5/13/01 as it was causing double endvoltas. This probably +c is only needed at the end in case there is no endvolta specified. +c if (onvolt) then +cc if (islast) write(11,'(a)')sq//'endvoltabox%' +cc onvolt = .false. +c end if +c +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page. Ugly repeated coding here. +c + mtrnms = mtrnuml + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + mtrnuml = mtrnms + if (movbrk .eq. 0 .and. islast) + * call wgmeter(mtrnmp,mtrdnp) + end if +c +c Key signature change? +c + if (btest(iplnow,28) .and. movbrk.eq.0) then + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)') + * notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-'//sq//'afterruleskip}' + * //sq//'zstoppiece'//sq//'PMXbarnotrue%' + else if (mtrnuml.gt.0 .and. movbrk.eq.0) then +c +c Meter change but no signature change +c + if (islast) + * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'// + * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq// + * 'barnoadd%' + if (islast) + * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'// + * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%' + else + if (islast) write(11,'(a)')sq//'stoppiece%' + end if +c +c This is the key spot when vshrink is used. Value of vshrink here comes from +c just after the prior pagebreak, i.e., it is not affected by "Av" +c that may have been entered at this pagebreak, since that only affects usevshrink. +c So choose page *ending* (with or without \vfill) depending on old vshrink. Then +c check value of usevshrink to reset vshrink if necessary for the new page, where +c we have to set \interstaff and later call puttitle. +c Top of first page needs special treatment. For this we use +c novshrinktop, which was set in g1etnote on the first pass, since on +c second pass, vshrink at top of page one is dealt with in topfile, which is called +c *before* any reading in any "Av" at the top of the first input block. +c + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject%' + else + if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%' + end if + ipage = ipage+1 +c +c Now that page is ejected, compute new vshrink +c + vshrink = xintstaff(ipage).gt.20 .and. usevshrink + if (vshrink) then + xinsnow = 10 + else + xinsnow = xintstaff(ipage) + end if + if (fintstf.gt.0 .and. ipage.gt.1) then + xinsnow = xinsnow*fintstf/gintstf + fintstf = -1. + end if + if (xinsnow .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else if (xinsnow .lt. 99.95) then + fmtq = '(a,f4.1,a)' + else + fmtq = '(a,f5.1,a)' + end if +c +c Vertical spacing parameters, then restart +c + if (islast) write(11,fmtq)sq//'interstaff{',xinsnow, + * '}'//sq//'contpiece' +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a)')sq//'newtimes2%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + end if + end if + end if +c +c If no real titles here, which there probably will never be, make vertical +c space at page top with \titles{...}. headlog=.false.<=>no real titles +c + call puttitle(inhnoh,xnsttop(ipage),etatop, + * sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + else +c +c First bar of system, not a new page, force line break +c + if (btest(iplnow,28)) then +c +c Signature change +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (mtrnuml .ne. 0) then +c +c Meter+sig change, new line, may need mods if movement break here. +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) then + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def' + * 'addspace{-'//sq//'afterruleskip}' +c * //sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + write(11,'(a)')sq//'addspace{-'//sq + * //'afterruleskip}%' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'zchangecontext' + end if + else + if (islast) write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// + * 'addspace{-'//sq//'afterruleskip}' +c * sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'alaligne' + else +c +c New meter, no new sig, end of line, not new page. +c +c \generalmeter{\meterfrac{3}{4}}% +c \xchangecontext\addspace{-\afterruleskip}% +c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% +c \zchangecontext +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) then + write(11,'(a)') + * sq//'let'//sq//'bnat'//sq//'barnoadd' + * //sq//'def'//sq//'barnoadd{'//sq//'empty}%' + write(11,'(a)')sq//'xchangecontext'//sq// + * 'addspace{-'//sq//'afterruleskip}'//sq// + * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'zchangecontext' + end if + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + end if + end if +c +c Modified 090525 to use \bnrs +c + if (slint) then + slint = .false. + if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq// + * 'raisebarno{',irzbnd,'.5'//sq//'internote}%' + end if + movbrk = 0 + end if +c +c Clean up if we squelched bar number reset at movement break +c + if (nobar1) then + if (islast) write(11,'(a)')sq//'startbarno1' + nobar1 = .false. + end if + read(12,*,end=14)iauto +14 continue +c +c We come thru here for the 1st bar of every system, so initialize is1n1 +c + is1n1 = 0 +c +c Brought down from above +c + if (isystpg .eq. nsystp(ipage)) isystpg = 0 +c +c Check for linebreak ties +c + if (ispstie) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + else +c +c Not first bar of system +c + if (btest(iplnow,28)) then +c +c Signature change +c + if (mtrnuml .ne. 0) then +c +c Meter+signature change mid line, assume no movement break +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) call wgmeter(mtrnmp,mtrdnp) + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:18)//'-' + lnote = 19 + end if + if (islast) then + iptemp = 48+abs(isig) + charq = chax(iptemp) + notexq = notexq(1:lnote)//charq//'}%' + lnote = lnote+3 + write(11,'(a)')notexq(1:lnote) + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + write(11,'(a)')sq//'xchangecontext%' + end if + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = (facmtr+naccs*.24)*musicsize + end if + else +c +c Signature change only +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) + * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'// sq//'afterruleskip}%' + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = naccs*.24*musicsize + end if + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'xbar' + else +c +c Change meter midline +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'xbar' + end if + end if + end if + end if +c +c Now that xbar's are written, can put in left-repeats at line beginnings +c + if (lrptpend) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1' + * //sq//'leftrepeat' + lrptpend = .false. + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nolev(ivx,ip) = nolev(ivx,ip+ioff) + nodur(ivx,ip) = nodur(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) + irest(ivx,ip) = irest(ivx,ip+ioff) + islur(ivx,ip) = islur(ivx,ip+ioff) + ipl(ivx,ip) = ipl(ivx,ip+ioff) + iornq(ivx,ip) = iornq(ivx,ip+ioff) + mult(ivx,ip) = mult(ivx,ip+ioff) +c if (ivx.le.2 .and. figbass) +c * isfig(ivx,ip) = isfig(ivx,ip+ioff) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + if (ivx.eq.1) then + isfig(1,ip) = isfig(1,ip+ioff) + else + isfig(2,ip) = isfig(2,ip+ioff) + end if + end if +12 continue + if (ivx.le.nv .and. ncc(iv).gt.1) then + islide = 0 + do 13 icc = 1 , ncc(iv) + if (tcc(iv,icc) .le. lenbar) then +c +c This time will drop <=0 when slid. +c + islide = icc-1 + ncmidcc(iv,1) = ncmidcc(iv,icc) + else + tcc(iv,icc-islide) = tcc(iv,icc)-lenbar + ncmidcc(iv,icc-islide) = ncmidcc(iv,icc) + end if +13 continue + ncc(iv) = ncc(iv)-islide + tcc(iv,1) = 0. + end if +11 continue + do 15 ig = 1 , ngrace + ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1) + if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2) +15 continue + do 21 il = 1 , nlit + iplit(il) = iplit(il)-nib(ivlit(il),ibar-1) + if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2) +21 continue + do 22 it = 1 , ntrill + iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1) + if (ibar .gt. 2) iptrill(it) = + * iptrill(it)+nib(ivtrill(it),ibar-2) +22 continue + do 27 icrd = 1 , ncrd +c ivx = iand(15,ishft(icrdat(icrd),-8)) + ivx = iand(15,ishft(icrdat(icrd),-8)) + * +16*igetbits(icrdat(icrd),1,28) + ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + icrdat(icrd) = iand(not(255),icrdat(icrd)) + icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd)) +27 continue + do 29 iudorn = 1 , nudorn +c ivx = iand(15,ishft(kudorn(iudorn),-8)) + ivx = ivxudorn(iudorn) + ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + kudorn(iudorn) = iand(not(255),kudorn(iudorn)) + kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn)) +29 continue + do 42 idyn = 1 , ndyn + idynd = idyndat(idyn) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10) + ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) +c +c The following construction avoids array bound errors in some compilers +c + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(idynd,8,4,ipnew) + idyndat(idyn) = idynd +42 continue + do 43 itxtdyn = 1 , ntxtdyn + idynd = ivxiptxt(itxtdyn) +c ivx = iand(15,idynd) + ivx = iand(31,idynd) +c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) + ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) +c call setbits(idynd,8,4,ipnew) + call setbits(idynd,8,5,ipnew) + ivxiptxt(itxtdyn) = idynd +43 continue + do 41 isdat = 1 , nsdat + isdata = isdat1(isdat) + ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1) + ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(isdata,8,3,ipnew) + isdat1(isdat) = isdata +41 continue + do 44 ibc = 1 , nbc +c ivx = iand(15,ibcdata(ibc)) + ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(ibcdata(ibc),8,4,ipnew) +44 continue + do 45 iarps = 1 , NumArpShift + IpArpShift(iarps) = + * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1) + if (ibar .gt. 2) then + IpArpShift(iarps) = + * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2) + end if +45 continue +c +c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. +c If there are figs left, it will reset all times relative to start of +c current bar. +c + do 46 ivx = 1 , 2 + if (figbass) then + islide = 0 + do 20 jfig = 1 , nfigs(ivx) + if (itfig(ivx,jfig) .lt. lenbar) then +c +c This figure was already used +c + islide = jfig + else + itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar + figq(ivx,jfig-islide) = figq(ivx,jfig) + itoff(ivx,jfig-islide) = itoff(ivx,jfig) + ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig) + end if +20 continue + nfigs(ivx) = nfigs(ivx)-islide + end if + if (nfigs(2) .eq. 0) go to 47 +46 continue +47 continue + end if +c +c End of sliding down for bars after first in gulp. +c +c The following may not be needed by makeabar, but just in case... +c + if (firstgulp .and. lenb0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenb0 + else + lenbar = lenb1 + end if + end if +c +c Equal line spacing stuff +c + if (equalize .and. bar1syst) then + if (isystpg .eq. 1) then + write(11,'(a)')sq//'starteq%' + else if (isystpg .eq. nsystp(ipage)-1) then + write(11,'(a)')sq//'endeq%' + end if + end if + call make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + call make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) +c +c Hardspace before barline? +c + hardb4 = 0. + do 35 iv = 1 , nv + do 35 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (btest(irest(ivx,nn(ivx)),18)) then + nudoff(ivx) = nudoff(ivx)+1 + hardb4 = max(hardb4,udoff(ivx,nudoff(ivx))) + end if +35 continue + if (hardb4 .gt. 0.) then + if (islast) write(11,'(a11,f5.1,a4)')sq + * //'hardspace{',hardb4,'pt}%' + fixednew = fixednew-hardb4 + end if +10 continue + firstgulp = .false. + lenb0 = 0 + go to 30 +40 close(12) + close(13) + ilbuf = 1 + ipbuf = 0 + wdpt = widthpt + if (iline .eq. 1) wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + poevec(nsyst) = poe + if (.not.islast) then + close(11) + close(16) + if (figbass) close(14) + return + end if + do 19 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +19 continue + do 26 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +26 continue + if (islast .and. + * onvolt) write(11,'(a)')sq//'endvoltabox' + if (rptfq2 .ne. 'E') then +c +c Terminal repeat. Right or double? +c + if (rptfq2 .eq. 'r') then + if (islast) write(11,'(a)')sq//'setrightrepeat' + * //sq//'endpiece' + else if (rptfq2 .eq. 'd') then + if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece' + else if (rptfq2 .eq. 'b') then + if (islast) write(11,'(a)')sq//'endpiece' + else if (rptfq2 .eq. 'z') then + if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece' + else +c else if (rptfq2 .ne. 'D') then + print* + print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + if (islast) write(11,'(a)')sq//'Endpiece' + end if + else + if (islast) write(11,'(a)')sq//'Endpiece' + end if + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + else + if (islast) write(11,'(a)') + * sq//'vfill'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + end if + rewind(11) + if (figbass) then + write(14,'(a9,i2,a10,i2,1x,a5)') + * sq//'figdrop=',ifigdr(1,iline), + * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%' + rewind(14) + end if + call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + if (.not.optimize) then + print* + print*,'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + print*,'Done with second PMX pass.' + write(15,'(/,a)')'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + write(15,'(a)')' Done with second PMX pass. Now run TeX' + end if + return + end + subroutine poestats(nsyst,poe,poebar,devnorm) + parameter (nks=125) +c +c Compute avg. & norm. std. dev. of poe. +c + real*4 poe(nks) + sumx = 0. + sumxx = 0. + do 1 isyst = 1 , nsyst + sumx = sumx+poe(isyst) + sumxx = sumxx+poe(isyst)**2 +1 continue +2 continue + devnorm = sqrt(nsyst*sumxx/sumx**2-1) + poebar = sumx/nsyst + return + end + subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq, + * twooftwo,icashft) +c +c Analyzes chords, data to be used with slurs on chords and plain chords. +c Check for 2nds, shift notes if neccesary. +c ipl(10) chord present +c irest(20) set if any note is right shifted +c irest(27) set if any note is left shifted +c ipl(8|9) left|right shift main note +c icrdat(23|24) ditto chord note +c udq is updown-ness, needed to analyze 2nds. +c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. +c icrdot(icrd)(27-29) sequence order of chord note if accid, top down +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,is2nd,twooftwo + integer*4 kicrd(10),levtabl(88) + character*1 udq + do 11 i = 1 , 88 + levtabl(i) = 0 +11 continue + do 1 icrd1 = 1 , ncrd + ivx1 = iand(15,ishft(icrdat(icrd1),-8)) + * +16*igetbits(icrdat(icrd1),1,28) + ip1 = iand(255,icrdat(icrd1)) + if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2 +1 continue + print* + print*, + * 'Cannot find first chord note in precrd. Send source to Dr. Don!' + call stop1() +2 continue + maxlev = nolevm + minlev = nolevm + levtabl(nolevm) = -1 + is2nd = .false. + naccid = 0 + levmaxacc = -100 + levminacc = 1000 +c +c Check 1st 3 bits of nacc for accid on main note of chord. +c + if (iand(7,nacc) .gt. 0) then + naccid = 1 +c +c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, +c otherwise icrd value for note with accidental. +c + kicrd(1) = 0 + levmaxacc = nolevm + levminacc = nolevm +c +c Start the level-ranking +c + icrdot0 = 1 + end if + do 3 icrd2 = icrd1 , ncrd + nolev = igetbits(icrdat(icrd2),7,12) + levtabl(nolev) = icrd2 + maxlev = max(maxlev,nolev) + minlev = min(minlev,nolev) +c +c Check for accidental +c + if (btest(icrdat(icrd2),19)) then + naccid = naccid+1 + levmaxacc = max(levmaxacc,nolev) + levminacc = min(levminacc,nolev) +c +c Add this icrd to list of values for notes with accid's. +c + kicrd(naccid) = icrd2 + if (.not.btest(nacc,28)) then +c +c Order not forced, so get the level-ranking, top down +c + iorder = 1 + do 12 iaccid = 1 , naccid-1 + if (kicrd(iaccid) .eq. 0) then + if (nolevm .gt. nolev) then + iorder = iorder+1 + else + icrdot0 = icrdot0+1 + end if + else + if (igetbits(icrdat(kicrd(iaccid)),7,12) + * .gt. nolev) then + iorder = iorder+1 + else + iold = igetbits(icrdot(kicrd(iaccid)),3,27) + call setbits(icrdot(kicrd(iaccid)),3,27,iold+1) + end if + end if +12 continue + call setbits(icrdot(icrd2),3,27,iorder) + end if + end if +c +c Exit loop if last note in this chord +c + if (icrd2 .eq. ncrd) go to 4 + if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or. +c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 + * igetbits(icrdat(icrd2+1),4,8) + * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4 +3 continue + print* + print*,'Failed to find last chord note. Send source to Dr. Don!' + call stop1() +4 continue +c +c Now icrd1, icrd2 define range of icrd for this chord. +c +c Bypass autos-shifting if any manual shifts are present +c + if (btest(irest,20) .or. btest(irest,27)) go to 10 +c +c Check for 2nds +c + do 5 ilev = 1 , 87 + if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then +c +c There is at least one 2nd.. +c + if (udq .eq. 'u') then +c +c Upstem. Start with 2nd just found and go up, rt-shifting upper +c member of each pair +c + ile = ilev +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,20) +7 continue + if (levtabl(ile+1) .lt. 0) then +c +c Upstem, & upper member is main so must be rt-shifted. This would move +c stem too, so we rt-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,30) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24) + else +c +c Upper member is chord note, must be rt-shifted +c + icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24) + end if + ile = ile+1 +8 continue + ile = ile+1 + if (ile .lt. 87) then + if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then + go to 7 + else + go to 8 + end if + end if + go to 10 + else +c +c Downstem. Start at top and work down, left-shifting lower member of each pair. +c We know that lowest pair is at (ilev,ilev+1). +c + ile = 88 +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,27) +9 continue + if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then + if (levtabl(ile-1) .lt. 0) then +c ipl = ibset(ipl,8) +c +c Dnstem, & lower member is main so must be left-shifted. This would move +c stem too, so we left-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,31) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23) + else +c +c Lower member is chord note, must be shifted +c + icrdat(levtabl(ile-1)) = + * ibset(icrdat(levtabl(ile-1)),23) + end if + ile = ile-1 + end if + ile = ile-1 + if (ile .ge. ilev+1) go to 9 + go to 10 + end if + end if +5 continue +10 continue +c +c Done with 2nds, now do accid's. Call even if just one, in case left shifts. +c +c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, + if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid, + * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft) + return + end + subroutine printl(string) + character*(*) string +c +c Send string to console and to log file +c + print*,string + write(15,'(a)')string + return + end + subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + logical lowdot,IsArpShift + character*80 soutq + character*79 notexq + character*8 symq(2) + character*1 chax + data symq /'raisearp','arpeggio'/ + +c +c Find which iarp, if any +c + do 1 iarp = 1 , narp + if (abs(tnow-tar(iarp)).lt.tol) go to 2 +1 continue +c +c If here, this is the *first* call for this arp. +c + narp = narp+1 + tar(narp) = tnow+tol*.5 + ivar1(narp) = iv + ipar1(narp) = ip + levar1(narp) = nolev + ncmar1(narp) = ncm + return +2 continue +c +c If here, this is *second* call at this time, iarp points to values from 1st. +c +c Check for shift. Set IsArpShift and iarps +c + do 3 iarps = 1 , NumArpShift + if (IvArpShift(iarps) .eq. ivar1(iarp) .and. + * IpArpShift(iarps) .eq. ipar1(iarp)) then + IsArpShift = .true. + notexq = chax(92)//'loffset{' + write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{' + lnote = 14 + go to 4 + end if +3 continue + IsArpShift = .false. + lnote = 0 +4 continue + if (iv .eq. ivar1(iarp)) then +c +c Arp is in a single staff. +c + levbot = min(levar1(iarp),nolev)-ncm+3 + invert = abs(levar1(iarp)-nolev)+1 + else +c +c Arp covers >1 staff. Lower staff has to be the first, upper is current and +c is where the symbol will be written. +c + levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) + invert = -levbot+4+nolev-ncm +c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' +c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), +c *levbot,nolev,ncm + end if +c +c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote +c + isym = mod(invert,2)+1 + ilvert = (invert+1)/2 + if (levbot .ge. 0 .and. levbot .le. 9) then +c +c Single digit +c + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//chax(48+levbot) + else + notexq = notexq(1:lnote)// + * chax(92)//symq(isym)//chax(48+levbot) + end if + lnote = lnote+10 + else + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//'{' + else + notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{' + end if + lnote = lnote+10 + if (levbot .ge. -9) then +c +c Need two spaces for number +c + write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}' + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}' + lnote = lnote+4 + end if + end if +c if (ilvert .le. 9) then +c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, +c * soutq,lsout) +c else +c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' +c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) +c end if + + if (ilvert .gt. 9) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+ilvert) + lnote = lnote+1 + end if + if (IsArpShift) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) +c +c cancel out the stored time, to permit two arps at same time! +c + tar(iarp) = -1. + return + end + subroutine putast(elask,indxask,outq) + character*129 outq,tag + character*9 fmtq + if (elask .ge. 0.) then + if (elask.lt.0.995) then + lp = 3 + else if (elask .lt. 9.995) then + lp = 4 + else + lp = 5 + end if + write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)' + else + lp = 5 + fmtq = '(a2,f5.1)' + end if +c +c Overwrite as follows: ...xyz*ask *lmnop... -> +c ...xyz*ast{.nn}*lmnop... +c ...xyz*ast{n.nn}*lmnop... +c ...xyz*ast{nn.nn}*lmnop... +c or for negative, ...xyz*ast{-nn.n}*lmnop... + tag = outq(indxask+9:) + write(outq(indxask+3:),fmtq)'t{',elask + outq = outq(1:indxask+4+lp)//'}'//tag + return + end + subroutine putcb(ivx,ip,notexq,lnote) + common /comcb/ nbc,ibcdata(36) + character*79 notexq + logical btest +c ivxip = ivx+16*ip + do 1 ibc = 1 , nbc +c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 +c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) +c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 + ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipbc = igetbits(ibcdata(ibc),8,4) + if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2 +1 continue + call printl('Error in putbc, Call Dr. Don') + stop +2 continue + if (btest(ibcdata(ibc),27)) then + lnote = 8 + notexq = char(92)//'pbreath' + else + lnote = 9 + notexq = char(92)//'pcaesura' + end if + ivshft = igetbits(ibcdata(ibc),6,13) +c?? ivshft = igetbits(ibcdata(ibc),6,13)-32 + if (ivshft .gt. 0) ivshft = ivshft-32 + if (ivshft.lt.0 .or. ivshft.gt.9) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (ivshft .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')ivshft + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')ivshft + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + notexq = notexq(1:lnote)//char(48+ivshft) + lnote = lnote+1 + end if + ihshft = igetbits(ibcdata(ibc),8,19) + if (ihshft .eq. 0) then + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else + hshft = .1*(ihshft-128) +c +c -12.81 ornament on a note, next line is top of manual loop. +c +2 continue +c +c Bit # of last ornament (last of bits 0-21) +cc Bit # of last ornament (last of bits 0-24) + ibit = log2(iand(iornq,4194303)) +c ibit = log2(iand(iornq,33554431)) + iornt = 2**ibit +c +c Begin routine to set height. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c 19-20: >^, 21: ? (with or w/o 16-18) +c +c Do not use beam height for . or _ +c + if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then +c +c Height is set by special beam stuff. +c Do not leave ihorn set, do separately for every ornament +c + ihorn = ihornb(ivx,nornb(ivx)) + if (ulpzq .eq. 'u') ihorn = ihorn-2 +c +c Following flag tells whether to increment nornb when exiting the subroutine. +c + usehornb = .true. + else if (ibit .eq. 14) then +c +c Down fermata. Don't worry about upper chord notes. +c + if (ulpzq .eq. 'l') then + ihorn = min(nolev,ncm-3) + else + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (btest(iornt,13) .or. btest(iornt,0)) then +c +c ( or ) +c + ihorn = nolev + else if (iand(iornt,6144) .gt. 0) then +c +cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info +c NOTE: removed .&_ from special beam treatment. +c Staccato . or tenuto _ Need up-down info +c + if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or. + * (minlev.ne.nolev.and.ulpzq.eq.'u')) then + ihorn = nolev + else if (maxlev .eq. nolev) then + ulpzq = 'u' + ihorn = max(nolev+stemlen,ncm+3.) + else + ulpzq = 'l' + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (iscrd .and. nolev .eq. minlev) then + if (ulpzq .eq. 'l') then + ihorn = min(nolev-3,ncm-6) + else + ihorn = min(nolev-nint(stemlen)-3,ncm-6) + end if + else if (ibit.eq.10 .and. nolev.gt.90) then +c +c Special treatment for fermata on a shifted rest +c + ihorn = ncm+5 + else if (ulpzq.eq.'l') then +c +c (iscrd and nolev=maxlev) or (.not.iscrd) +c + ihorn = max(nolev+stemlen+2,ncm+5.) + else + ihorn = max(nolev+2,ncm+5) + end if + ioff = 0 + iclracc = 0 +c +c Begin routine to set name. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c + if (btest(iornt,2)) then + notexq = sq//'shake' + lnote = 6 + else if (btest(iornt,3)) then + notexq = sq//'mordent' + lnote = 8 + else if (btest(iornt,1)) then + notexq = sq//'mtr' + lnote = 4 + else if (btest(iornt,5)) then + notexq = sq//'xtr' + lnote = 4 + else if (btest(iornt,6)) then + notexq = sq//'ptr' + lnote = 4 + else if (btest(iornt,13)) then + notexq = sq//'rpn' + lnote = 4 + else if (btest(iornt,0)) then + notexq = sq//'lpn' + lnote = 4 + else if (btest(iornt,12)) then + notexq = sq//ulpzq//'st' + lnote = 4 + else if (btest(iornt,11)) then + notexq = sq//ulpzq//'pz' + lnote = 4 + else if (btest(iornt,8)) then + notexq = sq//'upz' + lnote = 4 + ioff = -2 + else if (btest(iornt,9)) then + notexq = sq//'uppz' + lnote = 5 + ioff = -2 + else if (btest(iornt,10)) then + if (nodur .lt. 48) then + notexq = sq//'fermataup' + else + notexq = sq//'Fermataup' + end if + lnote = 10 + ioff = -2 + else if (btest(iornt,14)) then + if (nodur .lt. 48) then + notexq = sq//'fermatadown' + else + notexq = sq//'Fermatadown' + end if + lnote = 12 + else if (btest(iornt,21)) then +c +c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 +c + if (btest(iornq,16)) then + notexq = sq//'qsharp' + lnote = 7 + ioff = 2 + iornq = ibclr(iornq,16) + iclracc = 16 + else if (btest(iornq,17)) then + notexq = sq//'qflat' + lnote = 6 + ioff = 1 + iornq = ibclr(iornq,17) + iclracc = 17 + else if (btest(iornq,18)) then + notexq = sq//'qnat' + lnote = 5 + ioff = 2 + iornq = ibclr(iornq,18) + iclracc = 18 + else + notexq = sq//'qedit' + lnote = 6 + ioff = 0 + end if + else if (btest(iornt,16)) then + notexq = sq//'esharp' + lnote = 7 + ioff = 2 + else if (btest(iornt,17)) then + notexq = sq//'eflat' + lnote = 6 + ioff = 1 + else if (btest(iornt,18)) then + notexq = sq//'enat' + lnote = 5 + ioff = 2 + else if (btest(iornt,19)) then + notexq = sq//'usf' + lnote = 4 + ioff = -2 + else if (btest(iornt,20)) then + notexq = sq//'usfz' + lnote = 5 + ioff = -2 + end if + iudorn = 0 +c +c User-defined level shift of ornament from default? +c + if (btest(iornq,25)) then +c +c Find which (if any) element of kudorn has the shift. +c + do 3 iudorn = 1 , nudorn + if (ibit .lt. 21) then + ibitt = ibit +c +c Could have oes, but not oe? or oes? +c + else if (iclracc .gt. 0) then +c +c Earlier cleared edit. accid, meaning it was oes? +c + ibitt = iclracc+6 + else + ibitt = 21 + end if + ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19) +c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 + if (ibitt .eq. iand(33554431,kudorn(iudorn)) + * .and. ivx.eq.ivxudorn(iudorn)) go to 4 +3 continue +c +c Nothing shifted on this note; exit this if block +c + iudorn = 0 + go to 5 +4 continue + ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32 + if (ibit.eq.19 .and. ioffinc .lt. -7) then +c +c Convert usf to lsf. The reason has to do with positioning being impossile +c for some mysterious reason when you drop \usf below the staff +c + notexq = sq//'lsf' + ioffinc = ioffinc+6 + end if + ioff = ioff+ioffinc + end if +5 continue +c +c Shift level to avoid slur. Conditions are +c 1. There is a slur +c 2. No user-defined orn height shift (btest(iornq,25)) +c 3. upslur (islhgt>0) +c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 +c 5. islhgt+3 >= height already computed. +c + if (.not.btest(iornq,25) .and. + * islhgt.gt.0 .and. iand(iornt,30737).eq.0) + * ioff = ioff+dim(islhgt+3,ihorn ) + call notefq(noteq,lnoten,ihorn+ioff,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) + if (iand(iornt,32896) .gt. 0) then +c +c T-trill or trill w/o "tr" +c + call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote) + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + if (iudorn .gt. 0) then + if (btest(kudorn(iudorn),31)) then +c +c Horizontal shift +c + lform = lfmt1(ornhshft(iudorn)) + write(noteq(1:lform),'(f'//chax(48+lform)//'.1)') + * ornhshft(iudorn) + notexq = sq//'roffset{'//noteq(1:lform)//'}{' + * //notexq(1:lnote)//'}' + lnote = lnote+lform+12 + ornhshft(iudorn) = 0. + kudorn(iudorn) = ibclr(kudorn(iudorn),31) + end if + end if +c +c Zero out the bit for ornament just dealt with. +c + iornq = ibclr(iornq,ibit) + if (lout .eq. 0) then + outq = notexq(1:lnote) + else + outq = outq(1:lout)//notexq(1:lnote) + end if + lout = lout+lnote +c +c Check bits 0-21, go back if any are still set +c + if (iand(iornq,4194303) .gt. 0) go to 2 + if (usehornb) nornb(ivx) = nornb(ivx)+1 + return + end + subroutine putshft(ivx,onoff,soutq,lsout) + parameter (nm=24) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + character*80 soutq,notexq + character*1 sq,chax + logical onoff + sq = chax(92) +c +c Start user-defined offsets X(...): or X(...)S +c + if (onoff) nudoff(ivx) = nudoff(ivx)+1 +c +c Xoff is in pts. Round off to nearest .1. Will use at end of shift. +c + xoff = udoff(ivx,nudoff(ivx)) + xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff) + if (.not.onoff) xoff = -xoff + if (xoff .lt. -9.95) then + ifmt = 5 + else if (xoff.lt.-.95 .or. xoff.gt.9.95) then + ifmt = 4 + else + ifmt = 3 + end if + write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff + call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt, + * soutq,lsout) + return + end + subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc, + * etacs1,nv,vshrink,sepsymq) +c +c Called once per page, at top of page! If vshrink, only called for p.1. +c Actual titles only allowed on p.1. (set by headlog). +c 3/18/01: The above comment is probably bogus...can use Tt on later pages. +c + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + character*127 notexq + character*120 instrq,titleq,compoq + parameter (nm=24) + character*1 sq,sepsymq(nm),chax + logical headlog,vshrink + notexq = sq//'znotes' + lenline = 7 + do 22 iv = 1 , nv-1 + notexq = notexq(1:lenline)//sepsymq(iv) + lenline = lenline+1 +22 continue + notexq = notexq(1:lenline)//sq//'zcharnote{' + lenline = lenline+11 + if (.not.headlog) then + inhead = inhnoh + end if + if (vshrink .and. usevshrink) then + inhead = 16 + end if + ndig = int(alog10(inhead+.01))+1 + write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)// + * ',a10)')inhead,'}{'//sq//'titles{' + lenline = lenline+ndig+10 +c +c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether +c headers are present or not. +c + glueil = xnsttop/etatop + vskil = etatop*glueil + if (vshrink .and. usevshrink) vskil = 2 + call writflot(vskil,notexq,lenline) + if (.not.headlog) then + if (islast) write(11,'(a)')notexq(1:lenline) + * //'}{}{0}{}{0}{}{0}}'//sq//'en%' + else + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + lcq = lenstr(instrq,120) + if (lcq .gt. 0) then + xitil = etait*glueil + if (vshrink .and. usevshrink) xitil = 2 + notexq = notexq(1:lenline)//instrq(1:lcq)//'}{' +c +c Null out instrument once used +c + instrq = ' ' + lenline = lenline+lcq+2 + call writflot(xitil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}%' + notexq = '{' + lenline = 1 + lcq = lenstr(titleq,120) + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//titleq(1:lcq) + lenline = lenline+lcq + else + call printl(' ') + call printl('WARNING') + call printl( + * ' In a title block, you have specified instrument and/or') + call printl( + * ' composer but no title for the piece.') + end if + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + xtcil = etatc*glueil + lcq = lenstr(compoq,120) + if (lcq .eq. 0) xtcil = 2*xtcil + if (vshrink .and. usevshrink) xtcil = 2 + call writflot(xtcil,notexq,lenline) + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//compoq(1:lcq)//'}{' + lenline = lenline+2+lcq +c +c Null out compoq so it does not get written later +c + compoq = ' ' + xcsil = etacs1*glueil + if (vshrink .and. usevshrink) xcsil = 2 + call writflot(xcsil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%' + headlog = .false. + end if + return + end + subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom, + * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum, + * eloff,iup,irest,usexnumt) +c +c Places digit for xtuplet. +c + character*1 chax + character*8 noteq + character*79 notexq + logical btest,usexnumt + if (iflop.ne.0 .and. multb.gt.0) then +c +c Number goes on beam side, move R/L by .5 wheadpt for upper/lower +c + eloff = eloff-0.5*iud*wheadpt/poenom +c +c Number goes on beam side, must use beam parameters to set pos'n +c + nlnum = nolev1+islope/slfac*eloff+iup*(multb+8) + if (multb .ge. 2) nlnum = nlnum+iup + else + nlnum = nint(xnlmid-1+3*iud+iflop*11) + end if + if (.not.btest(islur,31)) then +c +c Only print number when wanted. First check vert, horiz offset +c + if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 + if (btest(irest,7)) eloff = eloff+ + * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom + if (.not.usexnumt) then + notexq = chax(92)//'xnum{' + lnote = 10 + istrtn = 7 + else + notexq = chax(92)//'xnumt{' + lnote = 11 + istrtn = 8 + end if + if (eloff .lt. 0.995) then + write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff + else if (eloff .lt. 9.995) then + write(notexq(istrtn:istrtn+3),'(f4.2)')eloff + else + write(notexq(istrtn:istrtn+4),'(f5.2)')eloff + lnote = lnote+1 + end if + call notefq(noteq,lnoten,nlnum,ncmid) + notexq = notexq(1:lnote)//'}'//noteq(1:lnoten) + lnote = lnote+1+lnoten + if (ntupv .lt. 10) then + write(notexq(lnote+1:lnote+1),'(i1)')ntupv + lnote = lnote+1 + else + notexq = notexq(1:lnote)//'{' + write(notexq(lnote+2:lnote+3),'(i2)')ntupv + notexq = notexq(1:lnote+3)//'}' + lnote = lnote+4 + end if + end if + return + end + subroutine read10(string,lastchar) + parameter (maxblks=4000) + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*(*) string + character*128 lnholdq + logical lastchar + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + if (.not.mplay) then + if (ilbuf .gt. nlbuf) go to 999 + call getbuf(string) + return +999 lastchar = .true. + return + else +c +c Play a macro. Set pointer to first character needed in buffer +c + if (ilmac .eq. il1mac(macnum)) then +c +c Getting first line of macro +c + ip1 = ip1mac(macnum) + iplmac = ip1-ic1mac(macnum) + else if (ilmac .le. il2mac(macnum)) then +c +c Beyond first line of macro. Advance line-start pointer. +c + iplmac = iplmac+lbuf(ilmac-1) + ip1 = iplmac+1 + else +c +c Beyond last line of macro. Terminate it! +c + mplay = .false. + endmac = .true. + return + end if + if (ilmac .eq. il2mac(macnum)) then +c +c Getting last line of macro. +c + ip2 = ip2mac(macnum) + else +c +c Getting line before last line of macro. +c + ip2 = iplmac+lbuf(ilmac) + end if + if (ip2 .ge. ip1) then + string = bufq(ip1:ip2) + else +c +c Kluge for when macro start is on a line by itself +c + string = ' ' + end if + ilmac = ilmac+1 + return + end if + end + function readin(lineq,iccount,nline) +c +c Reads a piece of setup data from file lineq, gets a new lineq from +c file 10 (jobname.pmx) and increments nline if needed, passes over +c comment lines +c + character*128 lineq + character*1 durq,chax +4 if (iccount .eq. 128) then +1 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 1 + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (lineq(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(lineq,iccount,durq) +c +c Remember that getchar increments iccount, then reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin + return + end + subroutine readmeter(lineq,iccount,mtrnum,mtrden) + character*128 lineq + character*1 durq,chax + if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then +c +c No slashes, so use old method +c + call getchar(lineq,iccount,durq) + if (durq .eq. '-') then +c +c Negative numerator is used only to printed; signals vertical slash +c + call getchar(lineq,iccount,durq) + mtrnum = -(ichar(durq)-48) + else if (durq .eq. 'o') then +c +c Numerator is EXACTLY 1 +c + mtrnum = 1 + else + mtrnum = ichar(durq)-48 + if (mtrnum .eq. 1) then +c +c Numerator is >9 +c + call getchar(lineq,iccount,durq) + mtrnum = 10+ichar(durq)-48 + end if + end if + call getchar(lineq,iccount,durq) + if (durq .eq. 'o') then + mtrden = 1 + else + mtrden = ichar(durq)-48 + if (mtrden .eq. 1) then + call getchar(lineq,iccount,durq) + mtrden = 10+ichar(durq)-48 + end if + end if + else +c +c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' +c + iccount = iccount+1 + ns = index(lineq(iccount:128),'/') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum +c +c Reset iccount to start of second integer +c + iccount = iccount+ns +c +c There must be either a slash or a blank at pos'n 2 or 3 +c + ns = index(lineq(iccount:iccount+2),'/') + if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden +c +c Set iccount to last character used +c + iccount = iccount+ns-1 + end if + return + end + subroutine readnum(lineq,iccount,durq,fnum) +c +c This reads a number starting at position iccount. Remember that on exit, +c getchar leaves iccount at the last character retrieved. So must only +c call this routine *after* detecting a number or decimal. +c On exit, durq is next character after end of number. +c + character*128 lineq + character*1 durq,chax + i1 = iccount +1 call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .gt. 0) go to 1 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then + i2 = i2-1 + iccount = iccount-1 + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum + return + end + subroutine setbits(isdata,iwidbit,ishift,ivalue) +c +c Sets iwidbits of isdata, shifted by ishift, to ivalue +c + ibase = 2**iwidbit-1 + if (ivalue.gt.ibase) then + print* + print*,'WARNING in setbits: ivalue > ibase' + write(15,'(/,a)')'WARNING in setbits: ivalue > ibase' + end if + isdata = iand(not(ishft(ibase,ishift)),isdata) + isdata = ior(isdata,ishft(ivalue,ishift)) + return + end + subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1) +c +c The MEAN SQUARE slope algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig + real*4 xelsk(24) + integer ipb(24) + ibc = ibmcnt(ivx) + sumxx = 0. + sumxy = 0. + do 2 inb = 1 , nnb + sumxx = sumxx+xelsk(inb)**2 + sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb)) +2 continue + delta = nnb*sumxx-sumx*sumx + em = (nnb*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*slfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/slfac*sumx)/nnb + nolev1 = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + do 4 inb = 1 , nnb + ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac + ynote = nolev(ivx,ipb(inb)) + smin = min(smin,iul*(ybeam-ynote)) +4 continue + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolev1 = nint(nolev1+iul*deficit) + end if + return + end + subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq, + * ivx,nline) + character*1 charq,durq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,btest + character*128 lnholdq,lineq + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac +c +c Macro action +c + call g1etchar(lineq,iccount,charq) + if (charq.eq.'S' .and. ivx.ne.1) then + print* + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"MS..." only put in parts by scor2prt if in voice #1!') + end if + if (index('RSP ',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "M" (macro)!') + call stop1() + else if (charq .ne. ' ') then +c +c Record or playback a macro. Get the number of the macro. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must input number after "MR","MP", or "MS"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macro number must be followed by a blank!') + call stop1() + end if + if (index('RS',charq ).gt. 0) then +c +c Record or save a macro +c + if (macnum.lt.1 .or. macnum.gt.20) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Macro number not in range 1-20!') + call stop1() +c else if (btest(macuse,macnum)) then +c print* +c print*,'WARNING: Redefining macro # ',macnum + end if + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + else if (charq .eq. 'S') then +c +c Save (Record but don't activate) +c +1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + if (mrecord) then + call getbuf(lineq) + nline = nline+1 + iccount = 0 + go to 1 + end if + iccount = iccount+ndxm+1 + end if + else +c +c Playback the macro +c + if (.not.btest(macuse,macnum)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a macro that has not been recorded!') + call stop1() + end if + icchold = iccount + lnholdq = lineq + iccount = 128 + mplay = .true. + ilmac = il1mac(macnum) + end if + end if + return + end + subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) +c +c Sets last 2 args depending on 1st 2, (logical) num, denom. +c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. +c 1: all duple meters +c 2: triple w/ denom=4, subdivide in groups of 2 8ths +c 3: triple w/ denom=8, subdivide in groups of 3 8ths +c Note that lenbar is set at top or when 'm' symbol is read in getnote +c + if (mtrdenl .eq. 4) then + if (mod(mtrnuml,3) .eq. 0) then + ibmtyp = 2 + ibmrep = mtrnuml/3 + else + ibmtyp = 1 + ibmrep = mtrnuml/2 + end if + else if (mtrdenl .eq. 2) then + ibmtyp = 1 + if (mtrnuml .eq. 3) then + ibmrep = 3 + else + ibmrep = 2*mtrnuml/mtrdenl + end if + else +c +c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 +c + ibmtyp = 3 + ibmrep = mtrnuml/3 + end if +c +c Reset so we don't keep writing new meters +c + mtrnuml = 0 +c +c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter +c + ibmrep = max(ibmrep,1) + return + end + subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest) +c +c The outer combo algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm + common /comeskz2/ eskz2(nm,200) + real*4 slope(800),xelsk(24) + integer ipb(24) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xels11(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + ibc = ibmcnt(ivx) + nxtinbm(ivx) = 0 + n1 = ipl2(ivx,ibm1(ivx,ibc)) +c +c Initialize counters used in this subroutine, and then later during actual +c beam drawing, to count later segments of single-slope beam groups +c + nssb(ivx) = 0 + issb(ivx) = 0 +c +c Set flag for xtup beam starting with rest (no others can start with rest) +c + if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1 +c +c Figure how many elemskips to each note. Use the list, counting only non-rests. +c + eskz0 = eskz(ivx,ibm1(ivx,ibc)) + nnb = 0 + sumx = 0. + sumy = 0. + ipxt1 = 0 + iplast = ibm2(ivx,ibc) + do 2 ip = ibm1(ivx,ibc) , iplast + if (.not.btest(irest(ivx,ip),0)) then + nnb = nnb+1 + ipb(nnb) = ip + xelsk(nnb) = eskz(ivx,ip)-eskz0 + sumx = sumx+xelsk(nnb) + sumy = sumy+nolev(ivx,ipb(nnb)) + if (btest(nacc(ivx,ip),21)) then +c +c This is the starting note of later segment of single-slope beam group +c Temporarily store ip here. +c + nssb(ivx) = nssb(ivx)+1 + lev1ssb(ivx,nssb(ivx)) = nnb + end if + end if +c +c New xtup stuff here. Final object is to get distance from start of xtup +c to number. xtinbm counts xtups in this beam only. mtupv is the printed +c number. ntupv is number of notes in xtup, and is only used to get +c eloff, the distance from start of xtup to the number. +c + if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1 + if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then +c +c Xtup is starting here +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + ipxt1 = ip + if (btest(nacc(ivx,ip),18)) then + ndoub = 1 + else + ndoub = 0 + end if + else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then +c +c Xtup ends here. Set total number of notes in xtup. +c + ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1 +c +c Set printed number for embedded xtup. +c + mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub +c +c Middle note of xtup if ntupv odd, note to left of gap if even. +c + ipxtmid = (ip+ipxt1)/2 + eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) + * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+ + * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid)) + ipxt1 = 0 + end if +2 continue +c +c Reset nxtinbm for use as counter as #'s are posted by putxtn(..) +c + nxtinbm(ivx) = 0 + smed = 0. + if (.not.btest(islur(ivx,ipb(1)),2)) then +c +c No forced 0 slope +c + if (nnb .eq. 1) go to 6 + nsc = 0 + do 5 inb = 1 , nnb-1 + do 5 jnb = inb+1 , nnb + nsc = nsc+1 + slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/ + * (xelsk(jnb)-xelsk(inb)) + if (abs(slope(nsc)) .lt. 1.e-4) then + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + end if +5 continue + if (nsc .eq. 1) then + smed = slope(1) + go to 6 + end if + nscmid = nsc/2+1 + do 7 i = 1 , nscmid + do 7 j = i+1 , nsc + if (slope(j) .lt. slope(i)) then + t = slope(j) + slope(j) = slope(i) + slope(i) = t + end if +7 continue + smed = slope(nscmid) + if (nsc .eq. 2*(nsc/2)) then +c +c Even number of slopes in the list, so median is ambiguous +c + if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then +c +c Lower-numbered one is truly less in absolute value, so use it +c + smed=slope(nscmid-1) + else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then +c +c Two slopes are effectively equal. Take the one with sign of the average +c + sum = 0. + do 1 i = 1 , nsc + sum = sum+slope(i) +1 continue + smed = sign(smed,sum) + end if + end if +6 continue + islope(ivx) = nint(0.5*smed*slfac) + if (iabs(islope(ivx)) .gt. 9) + * islope(ivx) = isign(9,islope(ivx)) + else +c +c Forced horizontal beam +c + islope(ivx) = 0 + end if + beta = (sumy-islope(ivx)/slfac*sumx)/nnb +c +c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use +c as is for placing xtup number and/or bracket, then reset it for start of +c actual beam +c + nolev1(ivx) = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + ssq = 0. + syb = 0. +c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) + yb1 = nolev1(ivx) + * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)) + do 4 inb = 1 , nnb + ybeam = yb1+islope(ivx)*xelsk(inb)/slfac +c * -iul*bmhgt*(mult(ivx,ipb(inb))-1) + * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1) + syb = syb+ybeam + ynote = nolev(ivx,ipb(inb)) + off = ybeam-ynote + if (inb .eq. 1) then + off1 = off + else if (inb .eq. nnb) then + off2 = off + end if + ssq = ssq+off*off + smin = min(smin,iul*off) +4 continue + dnolev = 0. + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolevo = nolev1(ivx) + nolev1(ivx) = nint(nolev1(ivx)+iul*deficit) + dnolev = nolev1(ivx)-nolevo + off1 = off1+dnolev + off2 = off2+dnolev + end if + ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2 + if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. + * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax) + * .and. .not.btest(islur(ivx,ipb(1)),2)) then +c +c The first check is to save trouble of putting xtup's in setbm2. +c The penultimate check is that first and last stems aren't both excessive. +c The last check is that a 0 slope has not been forced +c + call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx)) + end if +c +c Check if beam starts or ends too high or low. +c +c xboff = bmhgt*(mult(ivx,ipb(1))-1) + xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1) + l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0. + xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb) + l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0 + if (l1ng .or. l2ng) then +c +c Need to correct start or stop, also slope +c + if (l1ng) then + nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul) + end if + if (l2ng) then + xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul) + end if +c +c Since one or the other end has changed, need to change slope +c + if (.not.btest(islur(ivx,ipb(1)),2)) + * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb)) + end if + if (nssb(ivx) .gt. 0) then +c +c This is a single-slope beam group. Store start heights for later segs. +c + do 3 issbs = 1 , nssb(ivx) + lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac* + * xelsk(lev1ssb(ivx,issbs)) +3 continue + end if + return + end + subroutine sortpoe(nsyst,poe,ipoe) + parameter (nks=125) + real*4 poe(nks) + integer*4 ipoe(nks) +c +c Initialize ipoe: +c + do 3 iord = 1 , nsyst + ipoe(iord) = iord +3 continue +c +c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will +c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. +c + do 4 io1 = 1 , nsyst-1 + do 5 io2 = io1+1 , nsyst + if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then +c +c Interchange the indices +c + itemp = ipoe(io1) + ipoe(io1) = ipoe(io2) + ipoe(io2) = itemp + end if +5 continue +4 continue + return + end + subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 This subr is called ONLY for postscript slurs. +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 + isdat4(nsdat) = 0 + ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur +c +c Get ID code +c + call getchar(lineq,iccount,durq) + if (index('uldtb+-hfnHps ',durq) .gt. 0) then +c +c Null id. Note for ps slurs, 'H' cannot be an ID +c + iccount = iccount-1 + if (lineq(iccount:iccount) .eq. 't') then + idcode = 1 + else + idcode = 32 + end if + else +c +c Set explicit idcode +c + idcode = ichar(durq) + if (lineq(iccount-1:iccount-1) .eq. 't') then +c +c Make t[ID] look like s[ID]t +c + isdat2(nsdat) = ibset(isdat2(nsdat),3) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. +c + if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then +c +c There's a default curvature tweak +c + icurv1 = nint(SlurCurve)+3 + if (icurv1 .eq. 2) icurv1 = 1 + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + end if +c +c Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (durq .eq. 's') then +c +c Endpoint tweaks for linebreak slurs. +c + call getchar(lineq,iccount,durq) ! Must be +|- +c +c Next is vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32) + if (index('+-',dumq) .gt. 0) then +c +c Also a horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64) + end if + iccount = iccount-1 + ilb12 = 1 + go to 1 + else if (index('fnhH',durq).gt.0) then +c +c Special ps slur curvatures. +c Translate to old \midslur args (1,4,5,6) +c + icurv1 = index('fnxhH',durq) + if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + else if (durq .eq. 'p') then ! Local adjustment + call getchar(lineq,iccount,durq) ! +|- + call getchar(lineq,iccount,dumq) ! s|t +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) + if (durq .eq. '+') then + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),26) + else + isdat2(nsdat) = ibset(isdat2(nsdat),28) + end if + else + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),27) + else + isdat2(nsdat) = ibset(isdat2(nsdat),29) + end if + end if + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 +c +c Get id letter +c + if (lineq(iccount:iccount) .eq. 't') then +c +c Old-style t-slur. Use special idcode = 1 +c + idcode = 1 + else + call getchar(lineq,iccount,durq) + if (index('uldtb+-hf ',durq) .gt. 0) then +c +c Null id +c + idcode = 32 + iccount = iccount-1 + else if (durq.eq.'H') then +c +c Postscript slur, cannot use 'H' as code, must check for 2nd 'H' +c + idcode = 32 + iccount = iccount-1 +c +c There may be another "H", but no need to deal with it yet +c + else +c +c Set explicit idcode +c + idcode = ichar(durq) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (index('fhH',durq) .gt. 0) then +c +c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) +c + icurv1 = 2+index('fhH',durq) + if (icurv1 .eq. 3) then + icurv1 = 1 + else if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) +c +c Must change sign if downslur, but cannot do it now since we don't know +c slur direction for sure. +c + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine stop1() + call exit(1) + end + subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink,fontslur + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*79 inameq + character*44 basenameq + character*24 fmtq + character*5 fbarq + character*1 clefq(nm),sq,chax + common /comstart/ facmtr + logical vshrink,lowdot,rename + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) + sq = chax(92) + vshrink = xinstf1.gt.20. .and. .not.novshrinktop + if (vshrink) then + xinsnow = 10. + else + xinsnow = xinstf1 + end if + if (.not.islast) return + write(11,'(a)')'%%%%%%%%%%%%%%%%%' + write(11,'(a)')'%' + write(11,'(a)')'% '//basenameq(1:lbase)//'.tex' + write(11,'(a)')'%' + write(11,'(a)')'%%%%%%%%%%%%%%%%' + write(11,'(a)')sq//'input musixtex' + write(11,'(a)')sq//'input pmx' +c write(11,'(a)')sq//'input musixmad' +c write(11,'(a)')sq//'input musixxad' + write(11,'(a)') + * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%' + if (.not.fontslur) write(11,'(a)')sq//'input musixps' +c +c Need to input musixmad to permit more slurs. +c + if (musicsize .eq. 20) then + write(11,'(a)')sq//'normalmusicsize%' + else if (musicsize .eq. 16) then + write(11,'(a)')sq//'smallmusicsize%' + else if (musicsize .eq. 24) then + write(11,'(a)')sq//'largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterlargefont}%' + else if (musicsize .eq. 29) then + write(11,'(a)')sq//'Largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterLargefont}%' + end if +c +c Set sizes. Have sizes per staff in isize(.) and noinst per staff in +c nsperi(.) +c + iiv = 1 + do 5 iinst = 1 , noinst + if (isize(iiv) .eq. 1) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'smallvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'smallvalue%' + end if + else if (isize(iiv) .eq. 2) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'tinyvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'tinyvalue%' + end if + end if + iiv = iiv+nsperi(iinst) +5 continue +c +c do 5 iiv = 1 , nv +c if (isize(iiv) .eq. 1) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'smallvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'smallvalue%' +c end if +c else if (isize(iiv) .eq. 2) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'tinyvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' +c end if +c end if +c5 continue +c + write(fbarq,'(f5.3)')fbar + write(11,'(a)')sq//'nopagenumbers' + write(11,'(a)')sq//'tracingstats=2'//sq//'relax' + write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt' + write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)') + * sq//'vsize',int(height+.1),'pt' +c +c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if +c 3 sharps and treble clef, to avoid vertical clash with top space g# +c + if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)') + * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}' + if (noinst .lt. 10) then + write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + else + write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + end if + iv = 0 + do 1 iinst = 1 , noinst + nstaves = nsperi(iinst) + if (iinst .lt. 10) then + write(11,'(a)')sq//'setstaffs'//chax(48+iinst) + * //chax(48+nstaves) + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}' + * //chax(48+nstaves) + end if + iv = iv+1 + if (nstaves .eq. 1) then + fmtq = chax(48+numclef(clefq(iv))) + lfmtq = 1 + else + fmtq = '{'//chax(48+numclef(clefq(iv))) + lfmtq = 2 + do 2 k = 2 , nstaves + iv = iv+1 + fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv))) + lfmtq = lfmtq+1 +2 continue + fmtq = fmtq(1:lfmtq)//'}' + lfmtq = lfmtq+1 + end if + if (iinst .lt. 10) then + write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq) + else + write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq) + end if + do 3 lname = 79 , 2 , -1 + if (inameq(iinst)(lname:lname) .ne. ' ') go to 4 +3 continue +4 continue + lnam(iinst) = lname + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst, + * '{'//inameq(iinst)(1:lname)//'}' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst, + * '}{'//inameq(iinst)(1:lname)//'}' + end if +1 continue + write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%' + if (EarlyTransOn) + * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn) + call wgmeter(mtrnmp,mtrdnp) + ipi = nint(fracindent*widthpt) + if (ipi .lt. 10) then + write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip' + * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax' + if (.not.vshrink) then + if (xinstf1 .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' + * //sq//'interstaff{',xinstf1,'}'//sq//'relax' + else + write(11,'(a)')sq//'stafftopmarg0pt'// + * sq//'staffbotmarg5'//sq//'Interligne'//sq// + * 'interstaff{10}'//sq//'relax' + end if + if (nv.eq.1) write(11,'(a)')sq//'nostartrule' + write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}' + if (cstuplet) then + write(11,'(a)')sq//'input tuplet' + * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}' + * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}' + * //sq//'/'//sq//'/}}%' + write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet' + * //sq//'let'//sq//'unbkt'//sq//'downtuplet%' + end if + write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq// + * 'addspace'//sq//'afterruleskip%' + return + end + character*1 function udfq(nolev,ncm) +c +c Slur directions +c + common /combc/ bcspec + logical bcspec + ntest = nolev-ncm + if (ntest.lt.0 .or. + * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then + udfq = 'd' + else + udfq = 'u' + end if + return + end + character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv) +c +c Stem direction for single notes +c + character*1 ulfq + character*1 udqqq + logical btest + if (btest(isl,30)) then +c +c Absolute override +c + if (btest(isl,17)) then + udqqq = 'u' + else + udqqq = 'l' + end if + else if (nvmx .eq. 1) then +c +c Single voice per staff, default +c + udqqq = ulfq(1.*nole,ncm) + else +c +c Multi-voice per staff, 1st is lower, 2nd upper +c + if (ivx .le. nv) then + udqqq = 'l' + else + udqqq = 'u' + end if + end if + udqq = udqqq + return + end + character*1 function ulfq(xnolev,ncm) +c +c Stem directions +c + common /combc/ bcspec + logical bcspec + test = xnolev-ncm + if (test.lt.-.001 .or. + * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then + ulfq = 'u' + else + ulfq = 'l' + end if + return + end + function upcaseq(chq) + character*1 chq,upcaseq,chax + if (ichar(chq).ge.61.and.ichar(chq).lt.122) then + upcaseq = chax(ichar(chq)-32) + else + upcaseq = chq + print*,'Warning, upcaseq was called with improper argument: ' + * //chq + stop + end if + return + end + subroutine wgmeter(mtrnmp,mtrdnp) +c +c Writes meter stuff to file 11, so only called if islast=.true. +c + character*1 sq,chax + if (mtrdnp .eq. 0) return + sq=chax(92) + if (mtrnmp.gt.0 .and. mtrnmp.le.9) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i1,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .ge. 10) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i2,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i2,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .lt. 0) then + write(11,'(a26,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfracS{', + * -mtrnmp,'}{',mtrdnp,'}}%' + else if (mtrdnp .le. 4) then + write(11,'(a21,i1,a2)') + * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%' + else if (mtrdnp .eq. 5) then + write(11,'(a)')sq//'generalmeter'//sq//'allabreve%' + else if (mtrdnp .eq. 6) then + write(11,'(a)')sq//'generalmeter'//sq//'meterC%' + else if (mtrdnp .eq. 7) then + write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%' + end if + return + end + subroutine writemidi(jobname,ljob) + parameter(nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + character*1 byteq(4),char,chax + character*10 tempoq,instq + character*44 jobname + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,idsig, + * lnam(nm),inameq(nm) + logical rename + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) +c +c Used to be icmm(0:nm); did midi fail when nv>16? +c + integer*2 iinsiv(nm),icmm(0:15) + character*5 versionc + common /comver/ versionc +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c Can't remember why these were not consecutive. +c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ +c +c Write Header +c + write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6) + * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240) + if (debugmidi) + * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6, + * 0,1,0,numchan+1,0,240 +c +c Write the "conductor" track, for keys, meter, and tempos +c Get the number of bytes in the conductor event stream +c + ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec) + do 15 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec) +15 continue +c ib1 = (4+ljob+26+ndata+4)/256 +c ib0 = 4+ljob+26+ndata+4-256*ib1 + ib1 = (4+ljob+27+ndata+4)/256 + ib0 = 4+ljob+27+ndata+4-256*ib1 + write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0) +c +c Text header +c +c * //char(0)//char(255)//char(1)//char(ljob+26) + * //char(0)//char(255)//char(1)//char(ljob+27) + if (debugmidi) + * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0, + * 0,255,1,ljob+27 + write(51,'(a,$)')jobname(1:ljob) + if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"' +c +c (separate writes are needed to defeat compiler BUG!!!) +c +c write(51,'(a,$)')'.mid, produced by PMX 2.30' + write(51,'(a,$)')'.mid, produced by PMX '//versionc + if (debugmidi) write(52,'(a)') + * '".mid, produced by PMX '//versionc//'"' +c +c Conductor event data: Loop over sections. +c + do 16 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(numchan,isec) + else + mend = imidi(numchan) + end if + do 17 i = msecstrt(numchan,isec) , mend + write(51,'(a,$)')char(mmidi(numchan,i)) + if (debugmidi) write(52,'(z4)')mmidi(numchan,i) +17 continue +16 continue +c +c And close out the time sig / tempo track. +c + write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 +c +c Loop over track for each voice: The following sets up iv. +c + iv = nv + if (twoline(nv)) then + kv = 2 + else + kv = 1 + end if +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 +c + do 5 icm = 0 , numchan-1 +c +c Get the number of bytes in the data stream +c + ndata = 1+imidi(icm)-msecstrt(icm,nmidsec) + do 11 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec) +11 continue +c +cc Add 3 (for instrum) plus 4 (for closing) to byte count, +c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, +c +c ndata = ndata+7 + ndata = ndata+11 +c +c Add 4+lnam(iinsiv(iv)) if lnam>0 , +c + if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv)) +c +c Separate total byte counts into 4 bytes +c + do 2 ibyte = 1 , 4 + if (ndata .gt. 0) then + byteq(ibyte) = char(mod(ndata,256)) + ndata = ishft(ndata,-8) + else + byteq(ibyte) = char(0) + end if +2 continue +c +c Now write front stuff for this track +c + write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1) + * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) + * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm)) + if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm, + * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)), + * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), + * 0,11*16+icmm(icm),10,midbc(icm) + if (lnam(iinsiv(iv)) .gt. 0) then +c +c Add instrument name as sequence name +c + write(51,'(a,$)')char(0)//char(255)//char(3) + * //char(lnam(iinsiv(iv))) + if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv)) + write(51,'(a,$)') + * inameq(iinsiv(iv))(1:lnam(iinsiv(iv))) + if (debugmidi) write(52,'(a)') + * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"' + end if + write(tempoq,'(i2)')icm + write(instq,'(i3)')midinst(iv) + call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3)) +c +c Notes: Loop over sections. +c + do 9 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(icm,isec) + else + mend = imidi(icm) + end if + do 10 i = msecstrt(icm,isec) , mend + write(51,'(a,$)')char(mmidi(icm,i)) + if (debugmidi) write(52,'(z4)')mmidi(icm,i) +10 continue +9 continue +c +c Closing 4 bytes +c + write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 + if (kv .eq. 2) then + kv = 1 + else if (iv .eq. 1) then + go to 5 + else + iv = iv-1 + if (twoline(iv)) kv=2 + end if +5 continue + write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan) + write(15,'(1x,a12,(10i6))') + * 'Bytes used:',(imidi(icm),icm=0,numchan) + close(51) + if (debugmidi) close(52) + return + end + subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag) + parameter(nm=24) + integer*4 iInstTrans(nm),iTransKey(nm) + character*79 notexq + character*1 chax + logical flag +c +c Assumes notexq is blank +c + do 1 i = 1 , nInstTrans + notexq = chax(92)//'setsign' + lnote = 8 + if (iInstTrans(i) .lt. 10) then + notexq = notexq(1:lnote)//chax(48+iInstTrans(i)) + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iInstTrans(i),'}' + lnote = lnote+4 + end if + if (iTransKey(i) .lt. 0) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iTransKey(i),'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+iTransKey(i)) + lnote = lnote+1 + end if + write(11,'(a)')notexq(1:lnote)//'%' +1 continue + flag = .false. + return + end + subroutine writflot(x,notexq,lenline) + character*(*) notexq + if (x .lt. 0.95) then + write(notexq(lenline+1:lenline+2),'(f2.1)')x + lenline = lenline+2 + else if (x .lt. 9.95) then + write(notexq(lenline+1:lenline+3),'(f3.1)')x + lenline = lenline+3 + else + write(notexq(lenline+1:lenline+4),'(f4.1)')x + lenline = lenline+4 + end if + return + end + subroutine wsclef(iv,ninow,clefq,nclef) +c +c Writes \setclef for instrument containing voice iv +c + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + logical rename + character*1 clefq(nm),chax + character*20 temq + if (nclef .lt. 7) then + clefq(iv) = chax(48+nclef) + else + clefq(iv)='9' + end if + if (.not.islast) return + iv1 = 1 + do 1 iinst = 1 , ninow + if (iv .lt. iv1+nspern(iinst)) go to 2 + iv1 = iv1+nspern(iinst) +1 continue + print* + print*,'Should not be here in wsclef!' + call stop1() +2 continue + iv2 = iv1+nspern(iinst)-1 + if (iinst .lt. 10) then + temq = chax(92)//'setclef'//chax(48+iinst) + ltem = 9 + else + write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}' + ltem = 12 + end if + if (iv1 .eq. iv2) then + write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' + else + temq = temq(1:ltem)//'{' + ltem = ltem+1 + do 3 iiv = iv1 , iv2 + temq = temq(1:ltem)//chax(48+numclef(clefq(iiv))) + ltem = ltem+1 +3 continue + write(11,'(a)')temq(1:ltem)//'}%' + end if + return + end diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for b/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for new file mode 100644 index 00000000000..e5f73564979 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for @@ -0,0 +1,23646 @@ + program pmxab +c +c This program, PMX, developed by Don Simons +c (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with +c MusiXTeX and TeX, its purpose is to allow the user to create high-quality +c typeset musical scores by including a sequence of PMX commands in an ASCII +c input file. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c + character*9 date + character*5 version,versionc + common /comver/ versionc +c +c To compile with gfortran: +c 1. Merge all files using copy *.for epmx[nnnn].for +c 2. Search and replace all character*65536 with character*131072 +c 3. Comment/uncomment getarg lines +c 4. gfortran -O pmx[nnnn].for -o pmxab.exe +c +c To do +c Correct Rainer's email address in manual +c Linesplit (\\) in h +c Tt at start of a movement. +c Toggle midi on or off; allow midi only. +c Page number printed on 1st page even if 1 system. +c Still need inserted space for chordal accidentals +c Voicewise transposition. +c better segno +c coda +c duevolte +c Fix xtup bracket direction in 2-line staves?? (maybe leave as is) +c Sticky ornaments with shifts. +c Deal with Werner's vertical spacing thing associated with title. +c Multiple ties in midi +c Werner's missing c in MIDI due to start/stop ties on same note. +c Beams with single 64ths +c 128ths and/or dotted 64ths +c Close out MIDI with integral # of beats? +c Increase ast dimensions or redo logic. +c Does slur direction get set for user-defined single-note stem dir'ns? +c Transpose by sections. +c Optimization loop over sections only +c Command-line option to read nbarss in. Write out nbarss when optimizing. +c (or just read from .plg?) +c Beams over bar lines. +c 2-digit figures +c A real coule (slanted line between notes in a chord) +c Dotted slurs for grace notes. +c Undotted chord notes with dotted main note. +c Forced line break without line number +c Fix dot moving when 2nds in chord get flipped +c To do: increase length on notexq in dodyn +c 2.618 +c Add option Ac[l,4] to set vert and horiz size and offsets to properly +c center page for letter or a4 paper. +c 2.617 +c In g1etnote, change if-check for note to use index(...) instead +c of ichar(charq) since it was messing up gfortran optimizer +c After pmxa, search for and remove penultimate line / +c because it was screwing up linux-compiled versions +c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) +c 2.616 (111110) +c Allow hairpins to span multiple notes groups (gulps). +c 2.615+ (110810) +c Fix midi when some instruments are transposed, by subtracting +c iTransAmt(instno(iv)) from pitch values sent to via addmidi in +c make2bar.for (for main notes) and docrd (for chord notes) +c 2.615 (110725) +c Fig bug with size-setting (in topfile) when instrument has >1 staves +c 2.615 (110724) +c Make AS[0|-|s|t]... really set sizes +c 2.614 +c Mod notex.for to fix Terry's bug with raised dotted rests (caused +c by double-hboxing). +c 2.613 +c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. +c 2.612 +c Enhance AS to allow s or t for smallsize or tinysize +c 2.611 +c Error trap for "D" before any notes in a block. +c 2.610 +c Instrument-wise key changes and transposition (incomplete) +c 2.603 +c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors +c following reading in an include file. +c 101121 Added some error messages in g1etset.for setup data +c 2.602 +c Correct slur indexing in linebreakslurs. +c Account for comment lines in line count for error messages +c 2.601 +c Bug fix: allow 24 slurs with graces +c 2.60 Changes made make it really big +c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o +c major reprogramming, and 16 may also be a problem (icmm) +c nm=24 (voices) done +c 24 slurs done +c 24 simultaneous beams (Replace index 24 by 0, so get 0-23) +c bufq*131072 (gfortran only) +c getarg syntax (gfortran only) +c 2.523+ +c Fix voice numbering for normal dynamics and text dynamics +c 2.523 +c Version of bigpmx first posted to Hiroaki's web site. +c 2.522 +c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. +c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. +c 5/13/10 Fix log2 function +c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. +c 2.521+ +c 091025 Enable dotting 2nd part of linebreak slur or tie. +c To adjust barno height due to linebreak slur, use \bnrs instead of +c explicitly redefining \raisebarno (pmxb) +c 2.521 +c Bugfix +c 2.520 +c 090519 Enable ligfonts (special figured bass characters) +c 2.519 +c Fix another bug which kept \sk from being output so misaligned some notes. +c 2.518 +c Fix bugs: referencing fig data, char declaration for member of +c common/comfig/ +c 2.517 +c Allow figures in voice 1 + any one other. +c 2.516 +c Allow figures in voice #2 +c 2.515+ to do: Change manual and activate rule against clef change in voice #2. +c 2.515 +c 071222 Changes in getnote to allow auto forced beams to start anywhere. +c 071206 In make2bar, shift fermataup7 to left over centered pause. +c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line +c staff (it was screwing up vertical justification). +c n34 for tweaks to midi durations of quarter note septuplets. +c To do: In ref250.tex, the tables where 's,t,)' is explained, the line +c [+,- i] ... Vertical adjustment of the start of second segment +c should it be replaced by +c [s +,- i] ... Vertical adjustment of the start of second segment +c 2.514 +c Changes in make2bar to get horizontal spacing right when normal grace +c follows after grace +c Changes in dograce to get octaves right for any material entered inside +c \gaft, which shields transpose register changes from the outside world. +c 2.513 +c In make1bar, near end, for forced beams starting with a rest, copy hgt and +c slope tweaks to ALL notes after first, not just the second one, so if +c there's more than one rest at start the tweaks are still observed. +c In beamid and beamend, add stand-alone triply-flagged notes for xtups. +c 2.512 +c Near end of pmxb, fix error trap to allow redundant 'RD' +c Enable multiplicity down-up '][' within xtup. +c 2.511 +c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by +c adjusteskz as in bar 7 of barsant. +c 2.510a +c Test: remove restriction on tempo changes in MIDI macros +c Send to CM for beta testing. +c 2.509+ +c To do: Correct manual on AS. "-" is for smaller staves. +c 2.510 +c Forgot to declare litq, voltxtq as character in subroutine getgrace +c 2.509 +c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) +c 2.508 +c Allow graces in xtups. New subroutine getgrace. +c 2.507 +c To do: Raise/lower figures. +c To do: Add 24, 29 to list of musicsizes in manual +c New sub adjusteskz to account for ask's when computing lengths of +c brackets for unbeamed xtups, slopes and horizontal posn's of number +c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags +c Add look-left option for keyboard rests, "L" in rest command, set iornq(30) +c 2.506 +c Fix bug with AK, when simultaneous rests have same duration, use defaults. +c 2.505 +c Keyboard rests AK +c 2.504 +c Space after normal grace: option X[n] +c Fixed og when nv .ne. noinst, by using sepsymq instead of '&' +c (To do) length of xtup bracket when there is added non-collision space. +c Trap musicsize if .ne. 16,20,24,29. +c 2.503 +c Enable arpeggio left shift with ?-x +c To do: In manual, arpeggio over 2 staves. +c Allow musicsize of 24 and 29. Had to define meter font size explicitly, +c also change font size for text dynamics, but not much else so far. +c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn +c was called, causing error in printing replacement number. +c 2.502 +c Incorporate Dirk Laurie's patch to use { , } , for ties. +c Figure height adjustment: append +[n] +c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) +c 2.501 +c Readjust horizontal offset back to .8 in LineBreakTies +c Fix zero-subscript (iudorn) in putorn +c 2.50 +c Increase number of text-dynamics (dimension of txtdynq) per block +c from 12 to 41. +c Slur option n to override altered default curvature. +c Allow default ps slur curvature tweaks with Ap+/-c +c 2.416 +c Increase length of textdynq from 24 to 128 +c (Todo) Add comment in manual about blank lines at end. +c Configuration file: Define subroutine getpmxmod, check path in environment +c variable pmxmoddir, check existence, read lines into bufq after setup. +c Increase dimension on idynn in dodyn from 4 to 10 for max number +c of marks in a bar +c Increase allowable # of lines from 2000 to 4000. +c (To do) Replace definition of \liftpausc per Olivier. +c (To do) Fix extraneous error message if RD is placed at very end. +c 2.415 +c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt +c instead of redefining \xnum. Change font used to \smallfont (as for +c normal xtups, +c Allow slur to start on rest. +c 2.414 +c Correct bug in crdacc when adding accidental to boundary causes number of +c segments to decrease +c Special rule for 3-accidental chords: If no 2nds, place them in order +c top, bottom, middle. +c 2.413 +c Correct bugs in chordal accidentals, related to left-shifted noteheads +c (a) Special problems with downstem when main note needs shifting +c (b) Assign 0 rank to boundary segs due to left-shifted noteheads +c 2.412 +c Change default horiz shift of start of seg 2 of linebreak slurs: +c -.7 for slurs, -1.2 for ties, +c Use height of start of seg 1 slur itself for end of 1 and start of 2. +c 2.411 +c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. +c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end +c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. +c With "Apl", curvature adjustments on starting slur command apply to seg 1, +c those on ending command to seg 2. +c 2.410 +c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine +c \xnum, \unbkt, \ovbkt. +c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is +c flag, mult(5-9) is tweak value+16 +c 2.409 +c Bugfix in docrd for MIDI: Use original pitch in case main/chord were +c switched due to 2nds. +c Remove "o" from error message for "A" command. +c New syntax: optional instrument number separator ":" in movement +c break command to precede a 2-digit instrument. +c Conditional output formats for \setname at movement break to allow +c instrument numbers >9. +c Bugfix in coding to raise barno due to slur over line break (pmxb) +c Move date/version data statement in pmxab to a better place. +c 2.408 +c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). +c Bug fix in \liftPAusep in notex.for and in pmx.tex +c Character variables for version and date +c For up-stem single graces slurred to down-stem, shift slur start left by +c 0.8 so slur doesn't get too short. +c Initialize and slide mult, same as other full-program variables in /all/. +c 2.407 +c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, +c 2.406 +c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing +c equalization). +c Put dimensions of double sharps and flats in crdacc (for chords). +c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' +c Use only first 4 bits of mult for multiplicity+8, so rest can be used +c for other stuff. +c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. +c 2.405: Not published but saved for safety. +c Option Aph to write \special{header=psslurs.pro} top of each page, so +c dviselec will work OK. +c 2.404 +c Allow slur to end on rest, but not start on a rest. Efaults height +c of ending is default height of start (before any automatic or user- +c defined djustments). User may adjust height as normal from default. +c 2.403 +c Bugfix: turn off repeated beaming patterns.at end of non-last voice. +c 2.402 +c Automatic repeated forced beams. Start with "[:" End with next explicit +c forced beam or end of input block. +c Increase # of forced beams per line of music per input block from 20 to 40 +c 2.401 +c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. +c Makes 1st part normal shape, and starts 2nd part a little further left. +c Enable arpeggios in xtuplets. Had to make time itar(narp) a real. +c 2.40 +c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. +c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse +c sign for down-slurs. +c 2.359 +c Add error exit subroutine stop1 to make exit status g77-compatible.. +c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote +c Fermata on vertically shifted rest: special trap in putorn() to set height. +c Correct multiple grace note spacing for small staves (in dograce, +c define wheadpt1 depending on staff size) +c 2.358 +c Allow curvature corrections at start of postscript slur, in dopsslur() +c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust +c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] +c Make t[ID] act like s[ID]t, most mods in spsslur(). +c Add spsslur() to read in data for ps slurs, call from getnote. +c In beamstrt, save args for SetupB in common comipb to save them for +c 2nd call when xtup starts with rest +c Add spacing for ornament ")" as if it were accidental, in make2bar(). +c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() +c Horiz. shift start of ps grace slur, 2 places in dograce(). +c Horiz shift end of grace slur in endslur() +c Make st slurs into postscript ties. Separate subroutine dopsslur(), +c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) +c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. +c 2.357a +c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote +c 2.357 +c Increase dimension for # of lit TeX strings from 52 to 83. +c Allow blank rest in middle of xtuplet. Only mods in g*etnote(). +c 2.356 +c Increased some dimensions from 30 to 40 to allow up to 40 pages. +c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). +c Fix parsing of "f,h,H,HH" in sslur. +c Fix bug with cdot, note-level for slur termination (in getnote) +c 2.355 +c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], +c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues +c Make midi recognize ps ties in doslur. +c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote +c to get octave right. +c 2.354 +c With postscript slurs, make t-slurs real ties by inserting replacement +c macros \tieforisu, etc, defined in pmx.tex +c Check for open cresc or decresc at end of input block, using list[de]cresc +c Hairpin syntax conditional on postscript slurs. Backup to fill in start +c level, using new backfill(...). Separate height tweaks for +c start and finish. +c 2.353 +c K-0+n to transpose by half step (rather than just change key) +c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of +c \mbrest's +c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end +c of input block before movement break, and at start of block after +c movement break, using \newmovement rather than \setzalaligne, since +c former already redefines \stoppiece. In second case, set rptfg2='z'. +c Make clefq(nm) common between pmxb and getnote; change references in +c getnote at 'M' to array elements, setting all new clefs as you go. +c 2.352 +c Remove \parskip redefinition from pmx.tex; write it into TeX file when +c "Ae" is invoked. +c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine +c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', +c translate them thru mapping to (1,4,5,6) as \midslur params, then let +c \psforts translate them back to ps slur macors. +c 2.351 +c Number slurs from 0 up instead of 11 down, anticipating postscript slurs. +c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. +c Increase length of basenameq to 44 characters everywhere. +c Increase dimension of mcpitch (midi-chord-pitch) to 20. +c Set default systems per page to 1 if nv>7 +c In pmxb, move place where isystpg is reset to 0, so that \eject gets +c written when there is just one system per page. +c 2.35 +c Cautionary accidentals with 'c' anywhere in note symbol. +c NEW pmx.tex with \resetsize to set size to normal or small depending on +c current \internote. Used with new coding in dograce() to get right +c new size in case user has \setsize'ed some lines to \smallvalue. For +c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. +c Affects pmx.tex. +c Continuation figure with fractional length. May now mix with other figures. +c If another figure follow Cont-fig, separate with colon. +c 2.342 +c Bugfix in getnote to recognize relative octave shift in grace at start of +c input block. +c In make2bar, initialize islhgt=0 earlier than before (possible solution +c to Suse g77 compile problem that I could not reproduce).. +c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d +c 2.341 +c Syntax check: Forced page break page number must be > than previous. +c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. +c 2.34 +c New pmx.tex with redefined liftpausc +c Bug fix with dotted, non-beamed xtups. +c 2.332 +c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. +c Allow arbitrary pos. input to W in g1etnote and getnote. +c 2.331 +c Bug-fix in dodyn(..): typo on length of arg of txtdyn +c 2.33 +c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() +c 2.321 +c Rescale accidental shifts. Still use 7 bits but now map (0,127) +c onto (-1.,5.35) +c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups +c 2.32 (Noticed after posting) +c Prohibit "/" as figure. +c 2.32 (Posted) +c Tidied up accidentals in chords, do spacing. +c Still to do: +c check for "(" on chord notes in spacing algo +c small accids +c double accids +c autoshift slurs +c 2.310 +c Extra call to precrd ahead of spacing chk, and single-note crd/acc +c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. +c 2.309 +c Alternate algo for accid shifts in chords. +c 2.308 +c Auto horiz. notehead shifting added to precrd. +c 2.307 +c Auto shifting of multiple accidentals in chords. +c "Ao" in main chord note to keep accidentals in order. Set nacc(28). +c If there are any manual main or chord note shifts, then +c If any manual shift is preceded by "A" then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, +c End if +c End if +c 2.306 +c Initialize legacy note level to middle C in case user forgets to set +c octave. +c Shift xtup note? +c Shift in elemskips rather than noteheads? +c 2.305 +c Stop pmxb from multiple endvolta's at start of new page. +c 2.304 +c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on +c for multiple notes in the voice, "S:" last shortened note. +c 2.303 +c vshrink stuff all OK? Description is in pmxb. +c 2.302 +c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff +c hits 20. This still needs work. +c Add " /" to last line if last char is not % or /. +c 2.301 +c Check in beamn1 for single note before multiplicity down-up. +c allow '.PMX' as well as '.pmx' +c 2.299 +c Correct typo in pmxb involving PMXbarnotrue. +c Replacement printed number for xtup: Unsigned integer after 'n' after 'x' +c Minor upgrade parsing xtuplet options 'x...' +c Correct dimension of nxtinbm in make2bar. +c 2.298 +c Account for doubled xtup notes in subroutine getx (user-defined spaces), +c by adding ndoub as an argument.. +c 2.297 +c Created and solved compiler problem. Put drawbm(NM) in its own common. +c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar +c when \centerbar is used. +c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX +c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. +c 2.296 +c Correct printed numbers for forced beams with multiple xtups. For each beam +c make list in setupb by voice of eloff (h-offset) and mtupv (printed #) +c Increase lengths of jobname and infileq by 20 characters +c Enable whole notes and breves as 1st or last note of xtup in beamn1 and +c beamend, and wholes in beamid. +c 2.295 +c Midi balance Ib[n1]:[n2]:...[nn] +c Single-slope beam groups [...]-[...] +c Trap "i" unless after accidental (main notes, xtups, chord notes) +c 2.294 +c Unequal xtups with "D" to double a note in an xtup. +c As above, "F" will (a) increase multiplicity by 1 for marked note and next +c one and (b) add a dot to the first one. +c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on +c when "." is encountered, then correcting beam start time.(end of getnote) +c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... +c 2.293 +c Check for single notes spanning bar lines. +c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup +c must be set in make2bar since beamstrt is not called, fixing problem with +c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix +c problem when >2 staves. +c Add nodur to args of dodyn, so can check if stemless and avoid height tweak +c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak +c 2.292a +c Undo syntax check for Type 2 or 3 TeX string starting in column 1. +c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! +c 2.292 +c Allow comments in xtuplets +c Enable multiple octave jumps in grace notes. +c Allow dynamics in xtuplets. +c Fix bug in getdyn searching for end of text string (correct length of lineq +c to 128) +c Fix bug in dodyn, must ignore horiz. interaction tweak for +c user-text (idno = 0) +c Syntax check for Type 2 or 3 TeX string starting in column 1 +c (NOTE: later undone!) +c Syntax check for page number > npages at forced line break. +c 2.291 +c Fix error in AS command (accid spacing for small systems), making only +c one spec per staff, nv total. +c Stop using MIDI channel 10 +c 2.29 +c Fix error in console output format for # of bytes used in MIDI file. +c Fix bug in dograce so no space is added between grace and main note when +c there is a MIDI-only accidental. +c Fix bug so oes?+4 works. It was too ugly to explain. +c ...Different ways of storing accidental specs on input and output. +c No longer zap \writezbarno in special situations. +c Fix bug in dyntxt level on rest +c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. +c Activate with Ae. (Maybe later could input alternate values for +c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 +c in the page, and \endeq on 1st note of next-to-last line in page. +c 2.28 +c Flip direction of forced beam "[f..." +c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) +c Fix bug in sliding ip's for txtdyn's +c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) +c 2.27 +c Comment out lines in dodyn checking number of dynamic marks found. Voice +c order may not be monotonic if two lines on a staff. +c Literal dynamic: D"[text]" +c 2.26 +c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, +c increasing dimension of idynn to 4 to allow 4 symbols on same note. +c Increase voltxtq length from 10 to 20. +c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough +c accounting for ast's is done by defining effective headwidth +c whead1 in makebar2 to be 0.8*whead. +c 2.25 +c Fix logic bug with sepsym's when # of instruments changes. +c Slight increases in default offsets for hairpin starts after "p" +c 2.24 +c Hairpins D< or D> as toggle. +c Many automatic position tweaks for letter-group dynamics and hairpins. +c 2.23 +c Continued rhythmic shortcuts: space followed by "." or "," +c 2.22 +c In call to doslur, change tno(...) to tnote(...). This was only +c used when checking to slurs per stem directions, and should have been +c the note duration all along. +c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. +c Use "i" anywhere in note symbol. +c 2.21 +c Increase from 20 to 30 dimensions for movement breaks and midi sections. +c Fix out-of-order declarations per mutex comments +c Add "Bad error" and "Kluging" messages to log file. +c 2.197 +c add /comips/ to save tie-check midi variables +c For spacing of clef changes at start of input block, changed integer time +c lastnodur to prevtn, so it works with xtups. Possible incompatibility! +c 2.196 +c Fix Ickbug with time check in ncmid() +c Interchange \fermataup7 and \pausec to get proper alignment +c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. +c Add defn's of \hsp, \hspp to pmx.tex +c Fix pre-slurs on xtup chord notes. +c Fixed raised PAuse, define \liftPAuse +c Replace \zbreve\sk with \breve. +c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what +c about "o" and 1 as shorthand for 16???? Search for "Kluge" +c Added "vo" (voice) as MIDI instrument 55 +c Allow 3-digit page numbers (search for "toppageno") +c Fix bug caused by prior fix (cancelling accid after bar line was ignored). +c Fix double accids in chords +c 2.194 +c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if +c block. +c Add meter to MIDI file with every pause +c Purify FORTRAN? +c 2.193 +c Increased # of in-line TeX strings from 36 to 52. +c Fix entry of # of bytes in header of tempo/meter/key track to allow >255. +c 2.191 +c Event track: Tempos, meters, keys all together. Data in comevent +c 2.15 +c Pretty good midi capability. Still no attention to slurs on chord notes. +c 2.11 +c 11 Dec 99 c rm1 +c 11 Dec 99 "oes?", "oe?" +c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes +c 11 Dec 99 Error message for shifted, repeated ornaments. +c 2.10 (Version 2.1) +c Fix bug with lowdot and xtuplets +c 2.09 +c Fix bug with multiple ornament heights over beams, when one is . or _ +c Error message from pmxa if rest on last note of xtup. +c Enable 12 slurs. +c Reinstate multiple rests at start of xtup. +c 2.07 +c Combine consecutive type-1 TeX strings. +c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. +c Fixed breve chord notes in docrd +c Check irest(28) as well as vxtup when setting nodur for chord notes, since +c vxtup isn't set until 1st *main* note in xtup +c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. +c 2.06+ +c Make deterministic the beam slope calculation when there are an even # of +c slopes in list and middle two are equal magnitude but opposite sign. +c pmxa Trap for "o:" before 1st note in block +c Partial bug fix for 64th notes in xtuplets. +c Make ixrest a vector, since with new time scheme may not finish xtup in +c same notes block. +c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) +c 2.06 +c Account for changes in nv when computing \interstaff. Add a counter +c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever +c setting isysflb(iflb). Note nv can only change at a forced line break. +c Note also, iflb starts at 0! +c 2.05 +c Automatic start of new notes group with part 2 of staff-jump beam +c In make1bar, set irest bit 29 of lowest-voice note at same time, +c use as flag when making notes groups. +c For now, remove dummy blank line at end...it zaps terminal repeats. +c 2.02 +c Fixed slur-counting bug for multiple, slurred, aftergraces. +c 2.01 +c Increase to ask(1400) +c Increase max forced page breaks to 18 +c Define pausc for centered pause +c 2.0a +c Insert dummy blank line at very end to handle input files w/o terminal CR-LF +c pmx03r +c Option m[n] in S symbol to change musicsize (for parts) +c Double dotted rests now work. +c Write file name to log file +c Check existence of input file +c Allow 24-char jobname, may end with ".pmx" +c Comment out time stuff +c Replace 3-argument getarg with 2-argument + iargc +c Fix bug with negative noinst due to nint<=int replacement +c move lovation of iv in isdat1 to allow iv>7. +c Set nm=12 +c pmx03q +c replace int(x+.001) with nint(x) +c Write TeX file name to screen and to pml. +c Replace char(...) with chax(...) to sovle msdev bug. +c Bug fix: macro terminations when M is on a line by itself. +c Bug fix: don't accumulate space for XS in pmxa. +c Streamline Macros: use pointers to bufq instead of scratch files +c pmx03p +c Store input file in single character array bufq. +c lbuf(i)*2 is length of line i +c ipbuf is position just before next line to be read. +c pmx03 +c Optimize read/writes +c pmx02 +c Fix line count (for errors) when there are saved macros +c pmx01 +c In optimize mode, open/close macros (Watch out for residual zz files!) +c Command line input +c Option Ao to optimize, otherwise normal processing +c +ccccccc + parameter (nks=125,nm=24,mv=24576,maxblks=4000) + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /comevent/ miditime,lasttime + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + common /commus/ musize,whead20 + integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks) + real*4 poe0(nks),poe(nks) + logical isfirst,optimize + logical*4 fexist + character*44 jobname + character*47 infileq + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * idum,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + logical rest,firstline,newmeter + common /comdiag/ n69(0:nm),n34(0:nm) + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + common /truelinecount/ linewcom(20000) +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c +ccccccccccccccccccccccccc +c + data date /'19 Mar 12'/ + data version /'2618'/ +c +ccccccccccccccccccccccccc + data maxit,ncalls /200,0/ + data isfirst /.true./ +c itstart = mytime() + versionc = version +c +c Initialize midi parameters +c + gottempo = .false. + ismidi = .false. + debugmidi = .false. + relacc = .false. + mmacrec = .false. + nmidsec = 1 + mgap = 10 + miditime = 0 + lasttime = 0 + nmidcrd = 0 + nusebl = 0 + notmain = .false. + do 3 ivx = 1 , nm + twoline(ivx) = .false. + midinst(ivx) = 6 + midivel(ivx) = 127 + midibal(ivx) = 64 + miditran(ivx) = 0 +3 continue + do 12 icm = 0 , nm + imidi(icm) = 0 + restpend(icm) = .false. + trest(icm) = 0. + levson(icm) = 0 + levsoff(icm) = 0 + slmon(icm) = .false. + naccbl(icm) = 0 + n69(icm) = 0 + n34(icm) = 0 + msecstrt(icm,1) = 1 +12 continue +c +c End of midi parameter initialization +c + musize = 0 + optimize = .false. + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else +c call getarg(1,jobname,idum) ! May need to replace this w/ next line + call getarg(1,jobname) + end if +10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then + print*,'Jobname is too long. Try again.' + call stop1() + else if (ljob .eq. 0) then + print*,'No was jobname entered. Try again.' + call stop1() + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. +c call getarg(2,jobname,idum) ! May need to replace this w/ next line + call getarg(2,jobname) + numargs = 1 + go to 10 + else + print*,'Illegal option on command line' + call stop1() + end if + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + call stop1() + else + infileq = jobname(1:ljob)//'.PMX' + end if + end if +c +c Open a log file +c + open(15,file=jobname(1:ljob)//'.pml') + call printl('This is PMX, Version '//version//', '//date) + ljob4 = ljob + call printl('Opening '//infileq) + open(18,file=infileq) +c +c Copy input file into common buffer +c + ipbuf = 0 + linewcom(1) = 1 + do 8 ilbuf = 1 , maxblks + ncomments = 0 +14 read(18,'(a)',end=9)lnholdq + lbuf(ilbuf) = lenstr(lnholdq,128) + if (lbuf(ilbuf) .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lbuf(ilbuf) = 1 + lnholdq = ' ' + end if +c +c Now line has at least one non blank character. Check for comment +c As of Version 260, do not copy comments into bufq +c But need to count %'s for error messaging +c if (lnholdq(1:1).eq.'%') go to 14 + if (lnholdq(1:1).eq.'%') then + ncomments = ncomments+1 + go to 14 + end if +c +c When here, have counted all preceding comments and have a real line +c + if (ilbuf .gt. 1) then + linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments + else + linewcom(1) = 1+ncomments + end if + if (ipbuf+lbuf(ilbuf).gt.65536) then + print*,'Too many characters in file, stopping' + call stop1() + end if + bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq + ipbuf = ipbuf+lbuf(ilbuf) +8 continue + call printl('Too many lines in input file') + call stop1() +9 continue +c +c Insert dummy line to handle input files w/o CR-LF at end. +c + nlbuf = ilbuf-1 +c nlbuf = ilbuf +c bufq(ipbuf+1:ipbuf+3) = ' / ' +c lbuf(nlbuf) = 3 + close(18) + do 6 numit = 1 , maxit + if (optimize) call printl('Starting an iteration') +c +c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. +c Otherwise, nbars0 is the input +c When islast=.false., pmxb only returns poe's, otherwise does whole job +c + call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize) + if (.not.optimize) then + if (ismidi) then +c +c Set up channel numbers for midi. +c + numchan = 0 + do 11 iv = nv , 1 , -1 + if (twoline(iv)) then + midchan(iv,2) = numchan + numchan = numchan+1 + end if + midchan(iv,1) = numchan + numchan = numchan+1 +11 continue +c +c numchan will now be the number of channels, but max channel # is numchan-1 +c +c Set up velocities, balances, and midi-transpositions +c + do 13 iv = nv , 1 , -1 + if (twoline(iv)) then + midvelc(midchan(iv,2)) = midivel(iv) + midbc(midchan(iv,2)) = midibal(iv) + midtc(midchan(iv,2)) = miditran(iv) + end if + midvelc(midchan(iv,1)) = midivel(iv) + midbc(midchan(iv,1)) = midibal(iv) + midtc(midchan(iv,1)) = miditran(iv) +13 continue + end if +c +c TEMPORARY!!! +c + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + do 10000 ilb = 1 , nlbuf +c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), +c * bufq(ip1:ip1+lbuf(ilb)-1), +c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), +c * k=min(3,lbuf(ilb)),1,-1) + ip1 = ip1+lbuf(ilb) +10000 continue + iplast = ip1-1 +c +c Check to see if (1) last line is "/" and (2) next to last +c line is "/" +c +c print*,'iplast:',iplast +c print*,'Last line:' +c print*,bufq(iplast+1-lbuf(nlbuf):iplast) +c print*,'Last char of next to last line:' +c print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) + if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then + if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then + print*,'Removing last line of "/"' + write(15,*)'Removing last line of "/"' + nlbuf = nlbuf-1 + end if + end if +c + call pmxb(.true.,poe0,ncalls,optimize) + if (ismidi) then +c +c Write midi file +c + open(51,file=jobname(1:ljob)//'.mid') + if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm') + call printl(' ') + call printl('Writing '//jobname(1:ljob)//'.mid') + call writemidi(jobname,ljob) + end if + close(15) + stop + end if + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + call pmxb(.false.,poe0,ncalls,optimize) + call poestats(nsyst,poe0,poebar0,devnorm0) +c +c Save initial deviation and line breaks for later comparison +c + if (numit .eq. 1) then + devpmx = devnorm0 + do 20 isys = 1 , nsyst + nbari(isys) = nbars0(isys) +20 continue + end if + call sortpoe(nsyst,poe0,ipoe) + do 1 iupord = nsyst , 1 , -1 + isysu = ipoe(iupord) + print*,'isysu=',isysu + write(15,*)'isysu=',isysu +c +c Skip if system isysu has poe0 < avg or isysd has poe0 > avg +c + if (poe0(isysu).lt.poebar0) go to 1 + do 5 idnord = 1 , nsyst + isysd = ipoe(idnord) + if (isysu.eq.isysd .or. nbars0(isysd).eq.1 + * .or. poe0(isysd).gt.poebar0) go to 5 + do 2 isyst = 1 , nsyst + nbars(isyst) = nbars0(isyst) + if (isyst .eq. isysu) then + nbars(isyst) = nbars(isyst)+1 + else if (isyst .eq. isysd) then + nbars(isyst) = nbars(isyst)-1 + end if +2 continue + call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize) + call pmxb(.false.,poe,ncalls,optimize) + call poestats(nsyst,poe,poebar,devnorm) + if (devnorm .lt. devnorm0) then + devnorm0 = devnorm + poebar0 = poebar + do 4 isys = 1 , nsyst + nbars0(isys) = nbars(isys) + poe0(isys) = poe(isys) +4 continue + print*,'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(15,*)'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call sortpoe(nsyst,poe0,ipoe) + go to 6 + end if +5 continue +1 continue +c +c If we get here, must have gone thru all switches and found nothing better, +c so done! +c + go to 7 +6 continue +7 continue + print*,'Optimum located, numit:',numit,', ncalls:',ncalls + write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls + print*,'Final error:',devnorm0,', initial error:',devpmx + write(15,*)'Final error:',devnorm0,', initial error:',devpmx + print*,'Percentage improvement:',100.*(1-devnorm0/devpmx) + write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx) + call printl('Initial bars/system:') + write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + call printl('Final bars/system:') + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize) + call pmxb(.true.,poe0,ncalls,optimize) +c itend = mytime() +c print*,'Elapsed time in ms:',itend-itstart +c write(15,*)'Elapsed time in ms:',itend-itstart + close(15) + end + subroutine accsym(nacc,acsymq,lacc) + character*3 acsymq + iacc = iand(nacc,7) + if (iacc .eq. 1) then + acsymq = 'fl' + lacc = 2 + else if (iacc .eq. 2) then + acsymq = 'sh' + lacc = 2 + else if (iacc .eq. 3) then + acsymq = 'na' + lacc = 2 + else if (iacc .eq. 5) then + acsymq = 'dfl' + lacc = 3 + else if (iacc .eq. 6) then + acsymq = 'dsh' + lacc = 3 + else + print*,'bad accidental: ',iacc + end if + return + end + subroutine addask(taskn,waskn,elaskn, + * fixednew,scaldold,tglp1,isudsp) + parameter (nm=24) + logical isudsp + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comtol/ tol + if (isudsp) then +c +c Find which udsp we're dealing with +c + do 1 iudsp = 1 , nudsp + if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2 +1 continue + print*,'You should note BEEE here in addask!' + call stop1() +2 continue +c +c Fixednew and scaldold must not be changed, since udsp's are already included +c in fsyst from pmxa, and udsp don't involve scaled space.. +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c Must add user-defined space to what's there already. +c + wask(naskb) = wask(naskb)+udsp(iudsp) + else +c +c This place has no other space. +c + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = udsp(iudsp) + elask(naskb) = 0. + end if + else +c +c This is a normal space, no effect if smaller than existing space +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c We already put in some space at this time +c Check if new one needs more space than old one at same time +c + if (waskn .gt. wask(naskb)) then + naskb = naskb-1 + else + return + end if + end if + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = waskn + elask(naskb) = elaskn + fixednew = fixednew+waskn + scaldold = scaldold+elaskn + end if + return + end + subroutine addblank(noteq,lnoten) + character*8 noteq + character*1 tchar + tchar = noteq + noteq = ' '//tchar + lnoten = 2 + return + end + subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd) + parameter (nm=24) + integer nfb(nm) + common /comtol/ tol + real*4 t1fb(nm,20),t2fb(nm,20) + character*1 ulfbq(nm,20) + ifbadd = 1 + nfb(iv) = nfb(iv)+1 + do 1 ifb = nfb(iv)-1 , 1 , -1 + if (tnew .lt. t1fb(iv,ifb)-tol) then + t1fb(iv,ifb+1) = t1fb(iv,ifb) + t2fb(iv,ifb+1) = t2fb(iv,ifb) + ulfbq(iv,ifb+1) = ulfbq(iv,ifb) + else + ifbadd = ifb+1 + go to 2 + end if +1 continue +2 continue + t1fb(iv,ifbadd) = tnew + ulfbq(iv,ifbadd) = 'x' + return + end +c +c + subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) + parameter(nm=24,mv=24576) + integer*2 mmidi,itk(25) + integer*4 itiesav(5,100) + character*1 notenumq + logical endrest,eximacc,it1found + logical rest + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Following variables are local but must be saved. I hope they are. +c (3/18/00) With g77 they are not, so add a common block here. +c +c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) + integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15) + common /comips/ ipslon,lusebl,jusebl +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c +c Cancel out barline accidentals if there's a rest. +c + if (rest) naccbl(icm) = 0 +c +c Special path to insert dummy rest at end of a section +c + if (endrest) go to 20 +c + do 7 ion = 0 , nmidcrd +c +c check if this is only to get pitch of a chord note +c + if (notmain) go to 6 +c +c check for rest +c + if (rest) then +c +c Will not put in a note, but must update timing +c + if (.not.restpend(icm)) then +c +c First rest in sequence, save the time +c + restpend(icm) = .true. + trest(icm) = time + else + trest(icm) = trest(icm)+time + end if +c +c Note: code checkers don't like the above due to calling addmidi(trest(icm)) +c but this only happens if rest at end of section (endrest=.true.) (called +c from getmidi(), in which case these above lines are bypassed. +c + call chkimidi(icm) + return + end if +c +c time tics +c + if (imidi(icm).gt.0 .and. ion.eq.0) then + idur = mgap + else + idur = 0 + end if + if (restpend(icm)) then + restpend(icm) = .false. + idur = idur+nint(15*trest(icm)) + end if +c +c time to start of note +c + idurvar = isetvarlen(idur,nby2on) + if (nby2on .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + do 2 i = 1 , nby2on +c +c imidi points to cell before highest (leftmost) byte. Start with lowest byte +c at far right, fill in backwards +c + mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256) + if (nby2on .gt. 1) idurvar = idurvar/256 +2 continue + imidi(icm) = imidi(icm)+nby2on-1 +c +c Note-on signal +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 9*16+icm + mmidi(icm,imidi(icm)) = 9*16+icmm(icm) +c +c Entry point for chord note pitch determination +c +6 continue +c +c Get midi pitch. On chord iteration, only do this first time (main note), +c since pitch was already computed for nonmain chord notes. +c + if (ion .eq. 0) then + ipsav = nolev*12./7+11 + ipsav0 = ipsav + if (isig .ne. 0) then +c +c Adjust for signature +c + notenumq = char(48+mod(nolev,7)) + if (isig.ge.index('4152630',notenumq)) then + ipsav = ipsav+1 + else if (-isig.ge.index('0362514',notenumq)) then + ipsav = ipsav-1 + end if + end if +c +c Deal with accidentals. +c +c iacc 0 1 2 3 4 5 6 7 +c effect X fl sh na X dfl dsh X +c iashft X -1 1 0 X -2 2 X +c + jacc = 0 + eximacc = .false. + if (iacc .gt. 0) then +c +c Adjust key-sig-adjusted pitch for explicit accidental (and exit) +c + jacc = iashft(iacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav +c +c (Above) Shift applies to diatonic pitch but will be added to adjusted one +c + else if (naccim(icm) .gt. 0) then +c +c Possible implicit accidental from earlier in the bar +c Check for prior accid in this bar at this note level +c + do 3 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + jacc = jaccim(icm,kacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 4 + end if +3 continue +4 continue + end if +c +c Must split off the following if block from those above because chord +c notes can cause naccim>0, forcing us to miss other chord note's +c accross-bar-line accidental +c + if (naccbl(icm).gt.0 .and. .not.eximacc) then +c +c Possible carryover accid from prior bar (or prior same-pitch note). +c + do 21 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev) then + jacc = jaccbl(icm,kacc) +c +c Since we are *using* the bar-line accid, must flag it to be saved for next. +c + nusebl = nusebl+1 + jusebl(nusebl) = jacc + lusebl(nusebl) = nolev + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 22 + end if +21 continue +22 continue + end if + ipsav = ipsav+jacc +c +c Midi transpositions +c + ipsav = ipsav+midtc(icm) + end if + if (notmain) then + mcpitch(nmidcrd) = ipsav +c +c Save pitch for tie checks +c + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + imidi(icm) = imidi(icm)+1 + if (ion.eq.0) then + mmidi(icm,imidi(icm)) = ipsav + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ion) + end if + end if + if (ion .eq. 0) then +c +c Only record accids for non-chords, main chord note during chord iteration +c and chordnotes on first call but not during iteration +c + if (iacc.gt.0) then +c +c Set marker for accidental for possible continuations later this bar +c but first check and clear earlier ones on same note. +c + do 23 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + do 24 macc = kacc , naccim(icm)-1 + laccim(icm,macc) = laccim(icm,macc+1) + jaccim(icm,macc) = jaccim(icm,macc+1) +24 continue + go to 25 + end if +23 continue + go to 26 +25 continue + naccim(icm) = naccim(icm)-1 +26 continue +c +c Flag new accidental +c + naccim(icm) = naccim(icm)+1 + laccim(icm,naccim(icm)) = nolev + jaccim(icm,naccim(icm)) = iashft(iacc) + end if +c +c Bail if this is a chord note on the first call (from docrd) +c + if (notmain) then + call chkimidi(icm) + return + end if + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 127 + mmidi(icm,imidi(icm)) = midvelc(icm) + call chkimidi(icm) +7 continue +c +c For tie checks +c + if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm) +c +c Entry point for special rests at section ends (endrest=T) +c +20 continue +c +c Now insert all the ends +c + do 8 ioff = 0 , nmidcrd + if (ioff .eq. 0) then +c +c time to end +c + idur1 = nint(15*time) + if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then + idur = idur1-mgap + else + idur = idur1 + end if +c +c Deal with roundoff problems with 7-tuplets on half or quarters +c + if (idur1 .eq. 69) then + n69(icm) = n69(icm)+1 +c if (mod(n69(icm)+6,7) .gt. 3) idur = 58 + if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1 + else if (idur1 .eq. 34) then + n34(icm) = n34(icm)+1 + if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1 + end if + idurvar = isetvarlen(idur,nby2off) + if (nby2off .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + call chkimidi(icm) + do 1 i = 1 , nby2off + mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256) + if (nby2off .gt. 1) idurvar = idurvar/256 +1 continue + imidi(icm) = imidi(icm)+nby2off-1 + else +c +c Inserting end of chord note, delta time is 0 +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + end if +c +c Note off +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 8*16+icm + mmidi(icm,imidi(icm)) = 8*16+icmm(icm) +c +c Pitch +c + imidi(icm) = imidi(icm)+1 + if (ioff .eq. 0) then + mmidi(icm,imidi(icm)) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ioff) + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + call chkimidi(icm) + if (endrest) then + return + end if +c +c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time +c +8 continue + naccbl(icm) = nusebl + if (nusebl .gt. 0) then +c +c Fix tables of "bar-line" accids that are saved due to consecutive notes. +c + do 30 kacc = 1 , nusebl + laccbl(icm,kacc) = lusebl(kacc) + jaccbl(icm,kacc) = jusebl(kacc) +30 continue + nusebl = 0 + end if +c +c Begin tie checks +c + if (slmon(icm)) then +c +c Prior note had a slur start +c + if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then +c +c We have a tie! (Assumed there would be no accidental on tie-ending note) +c Make a list of times of all events back to the one starting at imidso+1, +c which is at or before where the tie started. Ident tie start and stop by +c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) +c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial +c time. + nsav4tie = 0 + imidt = imidso(icm) +10 nsav4tie = nsav4tie+1 + itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes) + imidt = imidt+nbytes + do 11 j = 1 , 3 + itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j) +11 continue + imidt = imidt+3 + if (nsav4tie .eq. 1) then + itiesav(5,1) = itiesav(1,1) + else + itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+ + * itiesav(5,nsav4tie-1) + end if + if (imidt .ne. imidi(icm)) go to 10 +c +c Find which two pitches agree with saved slur pitch. +c + it1found = .false. + do 12 it2 = 1 , nsav4tie + if (itiesav(3,it2) .eq. ipslon(icm)) then + if (it1found) go to 13 + it1 = it2 + it1found = .true. + end if +12 continue + call printl( + * 'Program error, tied notes, send source to Dr. Don') + it1 = nsav4tie+1 + it2 = nsav4tie+1 +13 continue +c +c List the positions we want to keep +c + jsav = 0 + do 14 isav = 1 , nsav4tie + if (isav.eq.it1 .or. isav.eq.it2) go to 14 + jsav = jsav+1 + itk(jsav) = isav +14 continue + nsav4tie = nsav4tie-2 +c +c Now dump events it1 & it2, recompute times, restack mmidi. +c + imidi(icm) = imidso(icm) + do 15 isav = 1 ,nsav4tie + if (isav .eq. 1) then + idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes) + else + idurvar = isetvarlen(itiesav(5,itk(isav))- + * itiesav(5,itk(isav-1)),nbytes) + end if + imidi(icm) = imidi(icm)+1 + do 16 i = 1 , nbytes + mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256) + if (nbytes .gt. 1) idurvar = idurvar/256 +16 continue + imidi(icm) = imidi(icm)+nbytes-1 + do 17 i = 2 , 4 + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = itiesav(i,itk(isav)) +17 continue +15 continue + end if + slmon(icm) = .false. + levsoff(icm) = 0 + if (.not.dbltie) levson(icm) = 0 + end if + if (levson(icm).gt.0) slmon(icm) = .true. + if (nmidcrd .gt. 0) nmidcrd = 0 + call chkimidi(icm) + return + end + subroutine addstr(notexq,lnote,soutq,lsout) + common /comlast/ islast,usevshrink + logical islast,usevshrink + character*(*) notexq + character*80 soutq + if (lsout+lnote .gt. 72) then + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + end if + if (lsout .gt. 0) then + soutq = soutq(1:lsout)//notexq(1:lnote) + else + soutq = notexq(1:lnote) + end if + lsout = lsout+lnote + return + end + subroutine adjusteskz(ib,squez,istart,istop,poenom) +c +c For block ib, this adds accidental spaces to eskz, for use in getting +c length of xtup bracket and slopes of brackets and beams. +c + parameter (nm=24) + common /comas1/ naskb,task(40),wask(40),elask(40) + real*4 squez(80) + integer*4 istart(80),istop(80) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comeskz2/ eskz2(nm,200) + common /comtol/ tol + common /comntot/ ntot + inmin = istart(ib)+1 + do 10 iaskb = 1 , naskb + if (task(iaskb) .lt. to(istart(ib))-tol) go to 10 + eskadd = wask(iaskb)/poenom-elask(iaskb) + do 11 in = inmin , ntot + if (to(in) .gt. task(iaskb)-tol) then + eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd + if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1 + else + inmin = inmin+1 + end if +11 continue +10 continue + return + end + subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + logical figbass,ispoi,topmods,istype0,done,isbbm + common /comhsp/ hpttot(176) + common /compoi/ ispoi + common /combbm/ isbbm + common /comas3/ ask(2500),iask,topmods + character*40 pathnameq + character*44 basenameq + character*1 sq,chax + character*129 outq + sq = chax(92) + open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex') +c +c Transfer first 5 lines of main internal TeX file +c + do 11 il = 1 , 5 + call moveln(11,12,done) +11 continue + if (istype0) then +c +c Transfer literal TeX stuff from special scratch file +c + rewind(17) +10 call moveln(17,12,done) + if (.not.done) go to 10 + close(17) + end if +c +c Transfer next 2 lines from main scratch file +c + do 3 il = 1 , 2 + call moveln(11,12,done) +3 continue + if (ispoi) write(12,'(a)')sq//'input musixpoi' + if (isbbm) write(12,'(a)')sq//'input musixbbm' + if (figbass) then +c +c Transfer .fig data from scratch (unit 14) into external .tex (unit 12) +c +4 call moveln(14,12,done) + if (.not.done) go to 4 + close(14) + end if + iask = 0 + ihs = 0 +1 read(11,'(a129)',end=999)outq +c +c Hardspaces. +c + if (outq(1:5) .eq. sq//'xard') then + ihs = ihs+1 + outq(2:2) = 'h' + write(outq(12:15),'(f4.1)')hpttot(ihs) + lenout = 19 + go to 9 + end if +c +c This part hard-wires ask's into new .tex file as ast's +c +2 indxask = index(outq,sq//'ask') + if (indxask .ne. 0) then + iask = iask+1 + call putast(ask(iask),indxask,outq) + go to 2 + end if + lenout = llen(outq,129) +9 continue + write(12,'(a)')outq(1:lenout) +c +c If this is the line with "readmod", check for topmods. +c + if (topmods .and. outq(2:8).eq.'readmod') then + topmods = .false. + rewind(16) + do 7 il = 1 , 1000 + read(16,'(a129)',end=8)outq + lenout = llen(outq,129) +c +c We inserted the '%' in subroutine littex, to guarantee including blank. +c + write(12,'(a)')outq(1:lenout) +7 continue +8 continue + close(16) + end if + go to 1 +999 close(11) + close(12) + return + end + subroutine backfill(iunit,oldq,lenold,newq,lennew) +c +c In iunit, looks backward for oldq, overwrites newq +c Safest if both are same length! +c + character*128 lineq(200),nowq + character*(*) oldq,newq + linesback = 0 +1 continue + backspace(iunit) + read(iunit,'(a)')nowq + ndx = index(nowq,oldq(1:lenold)) +c +c Save the line just read +c + linesback = linesback+1 + lineq(linesback) = nowq + if (ndx .eq. 0) then + backspace(iunit) + go to 1 + end if +c +c If here, it's replacement time. +c + lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew) + * //nowq(ndx+lenold:128) + backspace(iunit) + do 2 line = linesback , 1 , -1 + write(iunit,'(a128)')lineq(line) +2 continue + return + end + subroutine beamend(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + character*4 tempq + character*8 noteq + character*79 notexq + ip = ipo(jn) + multip = iand(mult(ivx,ip),15)-8 + if (ixrest(ivx) .eq. 4) then +c +c This is the LAST note in the xtup (i.e., all rests before). Make single. +c + nodur(ivx,ip) = 2**(4-multip) + call notex(notexq,lnote) + ixrest(ivx) = 0 + return + end if + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip-1),27)) + * nodur(ivx,ip)=nodur(ivx,ip)/2 + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = lnoten+3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+1 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+2 + else if (multip .eq. -2) then + notexq = sq//'wh'//noteq + else if (multip .eq. -3) then + notexq = sq//'breve'//noteq + lnote = lnote+3 + else + print* + print*,'(Error in beamend, send source to Dr. Don)' + call stop1() + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + end if + end if + end if + return + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + lnote = 0 +c +c New way, with flipend, which was computed in beamstrt. +c + if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) + * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then +c +c This is not a one-noter from beam-jump. Check if multiplicity has increased +c + if (btest(irest(ivx,ip-1),0)) then +c +c Prior note is a rest, check one before that +c + mp = iand(mult(ivx,ip-2),15)-8 + else + mp = iand(mult(ivx,ip-1),15)-8 + end if + if (multip .gt. mp) then +c +c Assume 1-3, 2-3, or 1-2 +c + do 2 imp = multip , mp+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +2 continue + else if (btest(nacc(ivx,ip-1),27)) then +c +c 2nd member of dotted xtup +c + call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if + end if +c +c Beam termination and direction analysis +c + if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then +c +c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number +c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the +c voice of the 2nd part of jumped beam. (May need special treatment for +c multi-segment jump-beams +c + isbjmp = .true. + ivbj1 = ivx + ivbj2 = 0 + end if + if (.not.btest(irest(ivx,ip),23)) then +c +c This is either a normal beamend or end of a sequence of jump-beam segments, +c so some sort of termination is required +c + ulqq = ulq(ivx,ibmcnt(ivx)) + if (.not.isbjmp .or. ivx.ne.ivbj2) then +c +c Normal termination +c + call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) + else +c +c Terminate a sequence of jump-beam segments. +c + ulqq = chax(225-ichar(ulqq)) + call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote) + end if + end if +c +c And now the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (.not.vxtup(ivx)) then + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (.not.btest(iornq(ivx,ip),13)) then + notexq = notexq(1:lnote)//'p' + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if +c +c 5/25/08 Allow >12 +c 5/9/10 Up to 24; replace 24 with 0 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + if (isbjmp .and. ivx.eq.ivbj2 + * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false. + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamid(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm + character*79 notexq + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + character*8 noteq + character*4 tempq + lnote = 0 + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.btest(irest(ivx,ip),0)) then + multip = iand(mult(ivx,ip),15)-8 +c if (btest(islur(ivx,ip-1),3)) multip = multip+1 +c +c (Above test OK since must have ip>1). Double dotted note preceding +c +c Move the following, because can't ask for note until after checking for +c embedded xtup with number, due to ordering/octave feature. +c +c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) + end if + if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true. + if (vxtup(ivx)) then +c +c In an xtup +c + if (btest(irest(ivx,ip),0)) then +c +c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK +c + nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8)) + call notex(notexq,lnote) +c +c Re-zero so next note does not get confused +c + nodur(ivx,ip) = 0 + return + end if +c if (multip.le.0) then +c if (multip.le.0 .or. +c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip),19) .or. + * btest(nacc(ivx,ip),27)) then + nodur(ivx,ip)=3*nodur(ivx,ip)/2 + else if (btest(nacc(ivx,ip-1),27)) then + nodur(ivx,ip)=nodur(ivx,ip)/2 + end if + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else +c +c Use ulq for stem direction +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + end if + if (btest(nacc(ivx,ip),27)) then +c +c This note is regular dotted non-beamed xtup +c + notexq = notexq(1:3)//'p' + lnote = 4 + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + end if + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + else if (nodur(ivx,ip).eq.0) then +c +c In the beamed xtup but not the last note +c + if (nodur(ivx,ip-1).gt.0) then +c +c Embedded Xtup, mult>0, starts here. Put in number if needed +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + iud = 1 + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1 +c +c Get ip#, notelevel of middle note (or gap) in xtup +c + ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ip),14)) then + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Place number if needed +c + if (.not.btest(islur(ivx,ip),31)) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multip,iud,wheadpt,poenom, + * nolev1(ivx),islope(ivx),slfac, + * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum, + * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.) + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + else +c +c Intermediate note of xtup +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else +c +c Last note of xtup (but not last note of beam!) +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else if (btest(irest(ivx,ip),0)) then + call notex(notexq,lnote) + return + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if +c +c Check if multiplicity changes in a way requiring action +c + ipleft = ip-1 + if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1 + if (.not.btest(islur(ivx,ipleft),20)) then + multl = iand(15,mult(ivx,ipleft))-8 + else + multl = 1 + end if + mub = multip - multl + ipright = ip+1 + if (btest(irest(ivx,ipright),0)) ipright = ipright+1 + if (.not.btest(islur(ivx,ip),20)) then + multr = iand(15,mult(ivx,ipright))-8 + else + multr = 1 + end if + mua = multr-multip + if (mub.gt.0 .or. mua .lt. 0) then +c +c Multiplicity has increased from left or will decrease to right. Need action. +c + if (isbjmp .and. ivx.eq.ivbj2) then + ivb = ivbj1 + ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + else + ivb = ivx + ulqq = ulq(ivx,ibmcnt(ivx)) + end if + if (mua .ge. 0) then + call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote) + else if (multl .ge. multr) then + do 1 im = multip , 1+multr, -1 + call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) +1 continue + else + do 2 im = 1+multr, multip + call ntrbbb(im,'r',ulqq,ivb,notexq,lnote) +2 continue + call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote) + end if + else if (ip .gt. 1) then +c +c Check for 2nd member of dotted xtup +c + if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if +c +c Now put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (isdotted(nodur,ivx,ip)) then +c +c rule out ')' +c + if (.not.btest(iornq(ivx,ip),13)) then + if (.not.btest(islur(ivx,ip),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + else if (btest(nacc(ivx,ip),19) + * .or. btest(nacc(ivx,ip),27)) then +c +c Special dotted notation for 2:1 xtup, or normal dot in xtup +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c 5/25/08 Allow >12 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamn1(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /comoct/ noctup + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*8 noteq + character*79 notexq + ip1 = ipo(jn) + multip = iand(15,mult(ivx,ip1))-8 +c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then + if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then + lnote = 0 +c +c The rest was already written in beamstrt, so just get out of here +c + return + end if + nole = nolev(ivx,ipo(jn)) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ipo(jn)),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ipo(jn)),31)) then + nole = nole + 1 + end if + if (vxtup(ivx) .and. .not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip1),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip1) + nodur(ivx,ip1) = 2**(4-multip) + if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2 + call notex(notexq,lnote) + nodur(ivx,ip1) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + else if (multip .eq. -3) then + notexq = sq//'breve' + lnote = 6 + else + print* + print*,'(Error in beamn1, send source to Dr. Don)' + call stop1() + end if + if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then + notexq = notexq(1:3)//'p' + lnote = 4 + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + end if +c +c Check if mult. decreases from 1st note to 2nd +c + if (ibm2(ivx,ibmcnt(ivx)).gt.ip1 + * .or. btest(islur(ivx,ip1),20)) then +c +c More than one note or single-note before a multiplicity-down-up "][" +c + if (btest(islur(ivx,ip1),20)) then + multr = 1 + else if (.not.btest(irest(ivx,ip1+1),0)) then + multr = iand(15,mult(ivx,ip1+1))-8 + else + multr = iand(15,mult(ivx,ip1+2))-8 + end if + lnote = 0 + if (multr .lt. multip) then + do 1 im = multip , multr+1 , -1 + call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +1 continue + end if + end if +c +c Put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 +c +c Check for dot +c + isdotm = .false. + if (.not.vxtup(ivx)) then + nd = nodur(ivx,ipo(jn)) + if (nd.ne.0) then + if (2**log2(nd).ne.nd) then + if (.not.btest(iornq(ivx,ip1),13)) then + if (.not.btest(islur(ivx,ip1),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if + else if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) then +c +c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c Do the number; 0 if 12 +c +c 5/25/08 allow >12 +c + if (.not.btest(irest(ivx,ip1),24)) then +c call istring(mod(ivx,12),noteq,len) + call istring(mod(ivx,24),noteq,len) + else +c call istring(mod(ivbj1,12),noteq,len) + call istring(mod(ivbj1,24),noteq,len) + end if + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + character*79 inameq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm + common /comeskz2/ eskz2(nm,200) + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c The following is just to save the outputs from SetupB for the case of +c xtups starting with a rest, where beamstrt is called twice. +c + common /comipb/ nnb,sumx,sumy,ipb(24),smed + character*8 noteq + character*79 notexq,tempq + integer nornb(nm),ihornb(nm,24) + real*4 space(80),squez(80) + logical novshrinktop,cstuplet,usexnumt + common /comnvst/ novshrinktop,cstuplet + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ibc = ibmcnt(ivx) + ipb1 = ibm1(ivx,ibc) + multb = iand(15,mult(ivx,ipb1))-8 + ip = ipo(jn) +c +c Compute slopes and note offsets from start of beam. Inside SetupB, for each +c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. +c + if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) + * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) + if (btest(nacc(ivx,ip),21)) then +c +c This is start of later segment of single-slope beam group so use slope and +c height from prior beam. Slope is already OK. +c + issb(ivx) = issb(ivx)+1 + nolev1(ivx) = lev1ssb(ivx,issb(ivx)) + end if + lnote = 0 + drawbm(ivx) = .true. + if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then + vxtup(ivx) = .true. + nxtinbm(ivx) = nxtinbm(ivx)+1 +c +c irest(28)=>Xtup starts on this note. Set up for xtuplet. +c Number goes on notehead side at middle note (or gap) of xtup, unless that +c puts it in staff, then it flops to stem (or beam) side. +c __ __ +c | | | O | | +c O | | O +c |___| O |__| | +c +c iud -1 -1 1 1 ...stem direction +c iflop 0 1 -1 0 ...direction of flop +c iup -1 1 -1 1 ...direction of number and bracket +c + iud = 1 + if (ulq(ivx,ibc) .eq. 'u') iud = -1 +c +c Get ip#, note level of middle note (or gap) in xtup +c + ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ipb1),14)) then +c +c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) +c + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Determine if a beam is to be drawn +c + do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc) + if (iand(15,mult(ivx,ipp))-8 .le. 0) then + drawbm(ivx) = .false. + go to 6 + end if +5 continue + drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18) +6 continue +c +c Are we using tuplet.tex? +c + usexnumt = cstuplet .and. .not.drawbm(ivx) +c +c Place xtup number if needed +c + if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multb,iud,wheadpt, + * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1), + * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)), + * iup,irest(ivx,ipb1),usexnumt) + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam +c + if (.not.btest(islur(ivx,ipb1),31)) then +c +c Number printing has not been suppressed, so put in the bracket. +c scale = stretch factor for bracket if there are asx's +c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) +c + xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1) + * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib)) + if (iup .eq. 1) then + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'ovbkt' + else + notexq = sq//'ovbkt' + end if + else + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'unbkt' + else +c +c Introduced 12/5/98, req'd due to possible presence of in-line TeX +c + notexq = sq//'unbkt' + end if + end if + lnote = lnote+6 + if (iline.eq.1) then + smed = smed/(1.-fracindent) + end if + xslope = 1.8*smed*slfac + islope(ivx) = nint(xslope) + nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1)) + if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1 + if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4 + levbracket = nolev1(ivx) + if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1 + call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+lnoten+1 + if (xnsk .lt. 0.995) then + write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk + lnote = lnote+4 + else if (xnsk .lt. 9.995) then + write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk + lnote = lnote+5 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + if (btest(mult(ivx,ipb1),4)) then +c +c Tweak slope of bracket +c + islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16 + end if + if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (islope(ivx) .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx) + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx) + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx) + lnote = lnote+1 + end if +c +c Done with bracket +c + end if + if (ixrest(ivx) .eq. 1) then +c +c Put in the rest. Possible problem: Rest is a spacing char, but between +c beamstrt and beamn1 some non-spacing chars. are inserted. +c + 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 +c +c No need to come back through this subroutine (as would if rest starts bar +c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. +c + ixrest(ivx) = 0 + end if + return + end if +c +c End if block for non-beamed xtup start...note we returned +c + if (ixrest(ivx) .eq. 1) then +c +c Insert rest at start of beamed xtup. See above note for possible problem. +c + nodur(ivx,ipb1) = 2**(4-multb) + call notex(tempq,ltemp) + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//tempq(1:ltemp) + else + notexq = tempq(1:ltemp) + end if + lnote = lnote+ltemp +c +c Re-zero just in case! +c + nodur(ivx,ipb1) = 0 + ibm1(ivx,ibc) = ibm1(ivx,ibc)+1 +c +c See if next note is a non-rest +c + if (.not.btest(irest(ivx,ipb1+1),0)) then + ixrest(ivx) = 2 + else +c +c Suppress reprinting xtup number next time through beamstrt +c + islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31) +c +c Set new xtup start flag +c + irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28) + end if + return + end if + end if +c +c Just ended if block for xtups +c + if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then +c +c Move actual note writing to beamend +c + ixrest(ivx) = 4 + return + end if + if (issb(ivx) .eq. 0) then +c +c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed +c + iadj = igetbits(ipl(ivx,ipb1),6,11)-30 + if (iadj .ne. -30) then + nolev1(ivx) = nolev1(ivx)+iadj + do 2 isssb = 1 , nssb(ivx) + lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj +2 continue + end if + iadj = igetbits(ipl(ivx,ipb1),6,17)-30 + if (iadj .ne. -30) then + islope(ivx) = islope(ivx)+iadj + if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx)) + if (nssb(ivx) .gt. 0) then +c +c Cycle thru non-rest notes in SSBG, looking for bmstrts. +c + isssb = 0 + do 4 inb = 2, nnb + if (btest(nacc(ivx,ipb(inb)),21)) then +c +c Beam segment start. New start level + isssb = isssb+1 + lev1ssb(ivx,isssb) = + * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac + end if +4 continue + end if + end if + end if + iadj = igetbits(islur(ivx,ipb1),2,27) + addbrack = .false. + if (btest(ipl(ivx,ipb1),30)) then +c +c Check for altered starting polarity. Only in forced beams. Nominal start +c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). +c + if (ulq(ivx,ibc).eq.'u' .and. + * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'loff{' + else + notexq = notexq(1:lnote)//sq//'loff{' + end if + lnote = lnote+6 + addbrack = .true. + else if (ulq(ivx,ibc).eq.'l' .and. + * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'roff{' + else + notexq = notexq(1:lnote)//sq//'roff{' + end if + lnote = lnote+6 + addbrack = .true. + end if +c +c Check end level for possible flipping in forced beam. Have to do it +c here since with multiple voices, xelsk will not be preserved. +c + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then + bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc)) + else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then + bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc)) + end if + end if + call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote) +c +c Put in name of start level and slope, after correcting nolev1 if xtup +c started with a rest. +c + if (ixrest(ivx).eq.2) nolev1(ivx) = + * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac) + call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1)) + if (islope(ivx) .lt. 0) then + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+4+lnoten + write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}' + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+1+lnoten + write(notexq(lnote:lnote),'(i1)')islope(ivx) + end if +c +c Check for beam-thk fine-tuning +c + if (iadj .gt. 0) then + do 1 imp = multb+iadj , multb+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote) +1 continue + end if +c +c If we shifted, must close with right bracket +c + if (addbrack) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Get 'floor' zmin for figures +c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height +c won't be adjusted. If anyone ever needs that, need to duplicate this +c functionality up above, before exiting. +c + if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then + if (ivx .eq. 1) then + ivf = 1 + else + ivf = ivxfig2 + end if + zmult = 1.2*(multb-1) + ymin = 100. + do 3 inb = 1, nnb + if (isfig(ivf,ipb(inb))) then + if (ulq(iv,ibc) .eq. 'u') then + ybot = nolev(iv,ipb(inb)) + else + ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx) + * -stemlen-zmult + end if + ymin = min(ymin,ybot) + end if +3 continue + maxdrop = ncmid(iv,ipb1)-4-ymin+5.01 + ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop) + end if +c +c Compute ornament levels if needed +c + NomOrnLev = ncmid(iv,ipb1)+5 + iorn = 0 + do 8 inb = 1 , nnb + ip = ipb(inb) + if (.not.btest(iornq(ivx,ip),23)) go to 8 + if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then +c +c letter-dynamic or hairpin ending under down-beamed +c + iorn = iorn+1 + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + else if (.not.btest(ipl(ivx,ip),10)) then +c +c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD +c +c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if +c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) +c + if (ulq(ivx,ibc).eq.'u' .and. + * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then + iorn = iorn+1 + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + end if + else +c +c In a chord. Orn may be on main note or non-main or both. Set ihornb if +c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note +c + do 10 icrd1 = 1 , ncrd + if (iand(255,icrdat(icrd1)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11 +10 continue +11 continue +c +c Find outermost note, min or max depending on beam direction ulq. xto is true +c if there's an ornament on that note. Expand orn list to include ._, since if +c on extreme chord note in beam, will move. +c So ornaments are all except 0,4,13 (,g,) +c + levx = nolev(ivx,ip) + xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0 + icrdx = 0 + do 12 icrd = icrd1 , ncrd + if (iand(255,icrdat(icrd)) .ne. ip .or. + * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13 + levc = iand(127,ishft(icrdat(icrd),-12)) + if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or. + * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then + levx = levc + icrdx = icrd + xto = iand(icrdorn(icrd),4186094).gt.0 + end if +12 continue +13 continue +c +c If there's orn on extreme note, do stuff +c + if (xto) then + iorn = iorn+1 + if (ulq(ivx,ibc) .eq. 'u') then + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + else + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + end if + if (icrdx .eq. 0) then +c +c Affected ornament is on main note +c + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + else + icrdorn(icrdx) = ibset(icrdorn(icrdx),22) + end if + end if + end if +8 continue +c +c Henceforth nornb will be a counter. +c + if (iorn .gt. 0) nornb(ivx)=1 + if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0 + return + end + block data + parameter (nm=24) + common /comtol/ tol + common /comtrans/ cheadq + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + logical usefig + common /comstart/ facmtr + character*60 cheadq + character*120 instrq,titleq,compoq + logical headlog + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /combmh/ bmhgt,clefend + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) +c + data tol /.001/ + data cheadq + * /' '/ + data gslfac /9./ + data instrq,titleq,compoq,headlog /3*' ',.false./ +c +c meter space (pts) = xb4mbr = musicsize*facmtr +c + data facmtr /0.55/ + data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt + * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 , + * .7,.7 ,.9 ,.5 ,2.3 ,1.1 / + data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac + * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 / + data rtshfac / 1.0 / + data isize /nm*0/ +c +c From other +c + data ptheight,widthpt,hoffpt,voffpt, + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh + * / 740. , 524. , 0., 0., + * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12., + * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 / + data fracsys /30*0./ + data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1, +c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3, + * -0.3,0.3 / + data kbdrests /.false./, + * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/ + data EarlyTransOn, LaterInstTrans /2*.false./ + data iInstTrans /nm*0/ + end + subroutine catspace(space,squez,nnsk) + parameter (nkb=3999,maxblks=4000) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + logical gotclef + do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1 + if (abs(space-durb(iptr)) .lt. tol) then + if (abs(squez-sqzb(iptr)) .lt. tol) then +c +c Increment pre-existing entry +c + nnpd(iptr) = nnpd(iptr)+nnsk + return + end if + end if +16 continue +c +c Didn't find current duration & squez, so add a new entry. +c No particular reason to keep in order, so add at the end. +c + nnpd(nptr(ibarcnt+1)) = nnsk + durb(nptr(ibarcnt+1)) = space + sqzb(nptr(ibarcnt+1)) = squez + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + return + end + character*1 function chax(n) +c +c The only reason for this seemingly do-nothing function is to get around an +c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! +c + chax = char(n) + return + end + subroutine checkdyn(lineq,iccount,ibar) + character*128 lineq + character*1 durq,chax + character*4 dynsymq + logical txtdyn + txtdyn = .false. +c +c On entry, iccount is on "D" +c + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c Dynamic text +c + iend = index(lineq(iccount+2:128),'"') + if (iend .eq. 0) then + call errmsg(lineq,iccount+1,ibar, + * 'Dynamic text must be terminated with double quote!') + call stop1() + end if +c +c Set iccount to character after 2nd ", and set ipm +c + iccount = iccount+iend+2 + ipm = index('- +',lineq(iccount:iccount)) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "-", "+", or blank here!') + call stop1() + end if + else +c +c Expect ordinary dynamic +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) + if (ipm .gt. 0) go to 2 +1 continue +2 continue + if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then + call errmsg(lineq,iend-1,ibar, + * 'Wrong length for dynamic mark!') + call stop1() + end if + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ', + * dynsymq)+3)/4 + if (idno .eq. 0) then + call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!') + call stop1() + end if + iccount = iend + end if + if (ipm .ne. 2) then +c +c There is a vertical shift, have "+" or "-" +c + iccount = iccount+1 + if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected integer here for vertical offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + if (idno .gt. 63) then + call errmsg(lineq,iccount-1,ibar, + * 'Vertical offset for dynamic mark must be (-63,63)!') + call stop1() + end if + ipm = index('- +',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "+", "-", or blank here!') + call stop1() + end if + if (ipm .ne. 2) then +c +c There is a horizontal shift +c + iccount = iccount+1 + if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected number here for horizontal offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + if (idno .gt. 255) then + call errmsg(lineq,iccount-1,ibar, + * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!') + call stop1() + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibar, + * 'There should be a blank here!') + call stop1() + end if + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + return + end + subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) +c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, +c * icashft) + logical found1,iscacc,isarp,btest + integer icrdat(193) + found1 = .false. +c +c icashft will be max left shift of accid's in chord notes. +c Used only for spacing checks. +c Will include left shift of chord note itself. +c Rezero after use. +c + do 18 icrd = 1 , ncrd +c +c This if block cycles thru all chord notes on ivx,ip; then returns. +c + if (iand(255,icrdat(icrd)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then + found1 = .true. + iscacc = iscacc .or. + * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) +c +c Accid on this chord note, and it's not midi-only. +c +c irshft = igetbits(icrdot(icrd),7,20) +cc +cc Include increment for notehead shift +cc +c if (btest(icrdat(icrd),23)) then +c if (irshft .eq. 0) then +c irshft = 44 +c else +c irshft=irshft-20 +c end if +c end if +c if (irshft .ne. 0) then +cc +cc Accid on chord note is shifted. Include only left shift, in 20ths. +cc +c if (irshft .lt. 64) icashft = max(icashft,64-irshft) +c end if +c end if + isarp = isarp .or. btest(icrdat(icrd),25) + else if (found1) then + return + end if +18 continue + return + end + subroutine chkimidi(icm) + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + if (imidi(icm) .ge. mv) then + print* + print*,'Midi file is too long! It will be corrupted or worse' + write(*,'(a6,2x,4i8)') + * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3) + end if + return + end + subroutine chklit(lineq,iccount,literr) + character*128 lineq + character*1 charq,chax + literr = 0 + itype = 1 +17 call g1etchar(lineq,iccount,charq) + if (charq .eq. chax(92)) then + itype = itype+1 +c if (itype .eq. 2) then +c if (iccount .ne. 2 ) then +cc +cc type 2 or 3 tex string not starting in column 1 +cc +c literr = 3 +c return +c end if +c else if (itype .gt. 3) then + if (itype .gt. 3) then + literr = 1 + return + end if + go to 17 + end if + lenlit = itype +18 call g1etchar(lineq,iccount,charq) + if (charq.eq.chax(92)) then + call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then +c +c Starting a new tex command withing the string +c + lenlit = lenlit+2 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + else + lenlit = lenlit+1 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + return + end + subroutine chkpm4ac(lineq,iccount,nacc,moved) +c +c Called after getting +/-/ in a note (not rest). iccount is on the +-<>. +c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits +c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed +c numbers. If moved=.true., iccount on exit is on end of last number. +c If moved=.false., iccount still on +/- +c + logical moved,ishorz + character*128 lineq + character*1 durq + if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and. + * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then +c +c Prior char was accid & next is #; this may be start of accidental shift. +c Must test for "." above in case we get "<" or ">" +c + ipm = index('- +< >',lineq(iccount:iccount))-2 + if (lineq(iccount+1:iccount+1).eq.'.' .and. + * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then +c +c Rare case of [accid][+/-].[letter]. Bail out +c + moved = .false. + return + end if + ishorz = ipm .gt. 1 +c +c Save iccount in case it's not accid shift and we have to reset. +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (ishorz .or. index('+-',durq).gt.0) then +c +c This has to be accidental shift. Set vert. shift. +c + if (.not.ishorz) then +c +c +/- syntax, both shifts set, vertical first +c + call setbits(nacc,6,4,int(ipm*fnum+32.5)) + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else +c +c syntax, only horiz set +c + ipm = ipm-3 + end if +c +c Set horiz. shift +c + call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35))) + iccount = iccount-1 + moved = .true. + else +c +c False alarm. Reset everything and flow onward +c + moved = .false. + iccount = icsav + end if + else +c +c Either prior char was not 'sfn' or next was not digit, so take no action +c + moved = .false. + end if + return + end + subroutine clefsym(isl,notexq,lnote,nclef) +c +c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. +c + character*(*) notexq + character*1 chax + nclef = iand(ishft(isl,-12),7) + if (nclef .eq. 0) then +c +c treble +c + nlev = 2 + else if (nclef .gt. 6) then +c +c French violin +c + nlev = 0 + else if (nclef .lt. 5) then +c +c C-clef +c + nlev = 2*nclef-2 + else +c +c F-clef +c + nlev = 2*nclef-6 + end if + notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7)) + * //chax(48+nlev) + lnote = 10 + return + end + subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime, + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c micrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c segrb(1|2,.) x|y-coord of right-bdry segment +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c icrdot0 = top-down level-rank of main note among accid-notes +c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes +c twooftwo will be true 2nd time thru; signal to store shifts w/ notes +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50) + integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50), + * isetshft(10),ksegrb0(50) + logical lasttime,mainnote,twooftwo + data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 / + data segar / +c +c Fancy sharp boundary. fl,sh,na,dfl,dsh +c + * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2, +c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , +c meas value for y, natural is 1.6 + * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2, + * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / + data segal / +c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , +cc (meas. value is 3.08) ^^^^ +cc Raise top of flat so it interferes with bottom of sharp + * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2, + * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2, + * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / +c +c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) +c + data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 / +c +c Set up barrier segrb(iseg,ipoint) to define coords of corner points +c on stem+notes +c + do 11 iseg = 1 , nsegrb0 + segrb(1,iseg) = segrb0(1,iseg) + segrb(2,iseg) = segrb0(2,iseg) + ksegrb(iseg) = ksegrb0(iseg) +11 continue + nsegrb = nsegrb0 + rmsshift = 0. + shiftmin = 1000. + do 1 iwa = 1 , naccid +c +c Initialize shift for this note +c + shift = 0. + mainnote = micrd(iwa).eq.0 + isetshft(iwa) = -1 +c +c Get note level and accidental type +c + if (mainnote) then + nolev = nolevm + iacctype = iacctbl(igetbits(nacc,3,0)) + else + nolev = igetbits(icrdat(micrd(iwa)),7,12) + iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20)) + end if +c +c Cycle thru segments on right edge of this accidental +c + do 2 isega = 1 , nsegar(iacctype)-1 + ybotaseg = nolev+segar(iacctype,2,isega) + ytopaseg = nolev+segar(iacctype,2,isega+1) +c +c Cycle thru segments of right-hand barrier +c + do 3 isegrb = 1 , nsegrb-1 +c +c Must find all barrier segments that start below ytopseg & end above ybotseg +c + if (segrb(2,isegrb) .lt. ytopaseg) then +c +c Barrier seg starts below top of accid +c Check if barrier seg ends above bottom of accid +c + if (segrb(2,isegrb+1) .gt. ybotaseg) then + if (shift .gt. + * segrb(1,isegrb)-segar(iacctype,1,isega)) then + shift = segrb(1,isegrb)-segar(iacctype,1,isega) +c +c Record the cause of the shift +c + isetshft(iwa) = ksegrb(isegrb) + end if + end if +c +c Does barrier segment end above top of accid seg? +c + if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4 + end if +3 continue +4 continue +2 continue + if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001 + * .and. .not.lasttime) then +c if (nolev .eq. levmaxacc) then + if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then + rmsshift = 1000. + return + end if +c +c Does the following properly account for left-shifted noteheads? +c +c Top-down rank of this note we just shifted +c + if (mainnote) then + irank = icrdot0 + else + irank = igetbits(icrdot(micrd(iwa)),3,27) + end if +c +c Compare level-rank of this note vs. that of note that caused the shift. +c This has effect of checking for basic interferences from top down. +c +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c + if (isetshft(iwa) .lt. 0) then + iranksetter = 0 + else if (isetshft(iwa) .eq. 0) then + iranksetter = icrdot0 + else + iranksetter = igetbits(icrdot(isetshft(iwa)),3,27) + end if + if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then + rmsshift = 1000. + return + end if + end if + rmsshift = rmsshift+shift**2 + if (lasttime .and. abs(shift).gt..0001) then + if (mainnote) then + if (.not.btest(nacc,29)) go to 10 + else + if (.not.btest(icrdat(micrd(iwa)),29)) go to 10 + end if +c +c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there +c was a manual shift but auto-shift was zero, will not come thru here, but shift value +c will be left intact. +c + if (mainnote) then + shift = shift+.05*(igetbits(nacc,7,10)-107) + else + shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107) + end if +10 continue + if (twooftwo) then +c +c Record the shift for this accidental +c + if (shift .lt. -5.35) then + call printl(' ') + call printl('WARNING: auto-generated accidental '// + * 'shift too big for PMX, ignoring') + else + ishift = nint(20*(shift+5.35)) + if (mainnote) then + call setbits(nacc,7,10,ishift) + else + call setbits(icrdot(micrd(iwa)),7,20,ishift) + end if + end if + else +c +c This is the earlier call to precrd, so need minimum shift +c + shiftmin = min(shiftmin,shift) + end if + end if +c +c Bail out if this is the last accidental to check +c + if (iwa .eq. naccid) go to 1 +c +c Add this accidental to the right barrier! Count down from highest barrier segment, +c find 1st one starting below top of accid, and first one starting below bot. +c + do 5 ibelowtop = nsegrb , 1 , -1 + if (segrb(2,ibelowtop) .lt. + * nolev+segal(iacctype,2,nsegal(iacctype))) then + do 9 ibelowbot = ibelowtop , 1 , -1 + if (segrb(2,ibelowbot) .lt. + * nolev+segal(iacctype,2,1)) go to 6 +9 continue + print*,'Oops2!' + call stop1() + end if +5 continue + print*,'Ugh0! in crdaccs' + call stop1() +6 continue + netgain = nsegal(iacctype)-ibelowtop+ibelowbot +c +c Shift high segments up +c + if (netgain .ge. 0) then + do 7 isegrb = nsegrb , ibelowtop+1 , -1 + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +7 continue +c +c Set up 1st segment above accid +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + else +c +c netgain<0, must remove segments. Use same coding but reverse order, +c work from bottom up +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + do 12 isegrb = ibelowtop+1 , nsegrb + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +12 continue + end if +c +c Insert new segments +c + do 8 isega = 1 , nsegal(iacctype)-1 + segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega) + segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega) + if (mainnote) then + ksegrb(ibelowbot+isega) = 0 + else + ksegrb(ibelowbot+isega) = micrd(iwa) + end if +8 continue +c +c Update number of barrier segments +c + nsegrb = nsegrb+netgain +cc +cc Temporary printout for boundary segments as built up +cc +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) +cc +1 continue ! next accidental + if (lasttime .and. .not.twooftwo) then +c +c This is the final call on the pre-ask pass, so compute left-shift rqmt. +c + icashft = nint(-20*shiftmin) + end if +cc +cc Temporary printout for boundary segments +cc +c if (twooftwo) then +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa),isetshft(iwa),iwa=1,naccid) +c end if +cc + return + end + subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm, + * levmaxacc,levminacc,icrdot0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c +c This is called once per multi-accidental chord. In here, loop over all +c permutations of the order of accidental as stored in kicrd. Each time thru +c loop, call crdacc once, get rms shift. Only save permutation and rms value +c if it is less than old value. +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c Make consistent? 120106 +c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + real*4 segrb0(2,50) + logical btest,tagged,manual,lshift,twooftwo +cc +cc Temporary printout of level-rankings +cc +c write(15,'()') +c do 98 iacc = 1 , naccid +c if (kicrd(iacc) .eq. 0) then +c write(15,'(3i5)')nolevm,icrdot0 +c else +c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), +c * igetbits(icrdot(kicrd(iacc)),3,27) +c end if +c98 continue +cc +c +c Initialize right-barrier +c + segrb0(1,1) = 0. + segrb0(2,1) = -1000. + segrb0(1,2) = 0. + segrb0(2,2) = 1000. + nsegrb0 = 2 + ksegrb0(1) = -1 + ksegrb0(2) = -1 +c +c Search for left-shifted notes, Make up the initial right-barrier, which +c will be good for all permutations. +c irest()(27) is set if any notes are left-shifted +c Must use ALL chord notes, not just ones w/ accid's. +c + if (btest(irest,27)) then + do 15 icrd = icrd1-1, icrd2 + if (icrd .eq. icrd1-1) then +c +c Main note +c +c lshift = btest(ipl,8) + lshift = btest(ipl,8) .or. btest(nacc,31) + if (lshift) nolev = nolevm + else +c +c Chord note +c + lshift = btest(icrdat(icrd),23) +c if (lshift) nolev = igetbits(icrdat(icrd),7,12) + if (lshift) then + nolev = igetbits(icrdat(icrd),7,12) + if (btest(nacc,31) .and. nolev.eq.nolevm+1) then +c +c This note is not really shifted, It is the upper of a 2nd with the main +c note on an upstem, and Main note must be shifted. +c nacc(31) signals the real truth. +c + lshift = .false. + end if + end if + end if + if (lshift) then + do 16 isegrb = 1 , nsegrb0-1 + if (segrb0(2,isegrb+1) .gt. nolev-1) then +c +c Add this notehead to the right boundary here. Move all higher segs up 2. +c + do 17 iiseg = nsegrb0 , isegrb+1 , -1 + segrb0(1,iiseg+2) = segrb0(1,iiseg) + segrb0(2,iiseg+2) = segrb0(2,iiseg) + ksegrb0(iiseg+2) = ksegrb0(iiseg) +17 continue + go to 18 + end if +16 continue +18 continue +c +c Insert notehead into list. Set kseg=-2 to signal notehead shift. +c + iiseg = isegrb+1 + segrb0(1,iiseg) = -1.2 + segrb0(2,iiseg) = nolev-1. + ksegrb0(iiseg) = -2 + segrb0(1,iiseg+1) = 0. + segrb0(2,iiseg+1) = nolev+1. + ksegrb0(iiseg+1) = -1 + nsegrb0 = nsegrb0+2 + end if +15 continue + end if +c +c Done setting right barrier for left-shifted noteheads +c + tagged = .false. + manual = .false. +c +c Preprocess to check for manual shifts. +c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then +c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, Observe all manual shifts. +c End if +c End if +c + maxmanshft = 0 + do 13 i = 1 , naccid + if (kicrd(i) .eq. 0) then +c +c Main note +c + manshft = igetbits(nacc,7,10) + if (manshft .ne. 0) then + manual = .true. + if (btest(nacc,29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + else +c +c Chord note +c + manshft = igetbits(icrdot(kicrd(i)),7,20) + if (manshft .ne. 0) then + manual = .true. + if (btest(icrdat(kicrd(i)),29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + end if +13 continue + if (manual) then + if (tagged) then +c +c zero out all untagged shifts +c + do 14 i = 1 , naccid + if (kicrd(i) .eq. 0) then + if (.not.btest(nacc,29)) call setbits (nacc,7,10,0) + else + if (.not.btest(icrdat(kicrd(i)),29)) + * call setbits (icrdot(kicrd(i)),7,20,0) + end if +14 continue + else +c +c There are manual shifts but none tagged. Only proceed if "Ao" was entered +c + if (.not.btest(nacc,28)) then + icashft = maxmanshft + return + end if + end if + end if + if (btest(nacc,28)) then +c +c Take the accidentals in order as originally input, then exit. +c + call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return +c end if + else if (naccid .eq. 3) then +c +c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd +c then place in order top, bottom, middle. +c + do 20 i = 1 , 3 + if (kicrd(i) .eq. 0) then + irank = icrdot0 + nolev = nolevm + else + irank = igetbits(icrdot(kicrd(i)),3,27) + nolev = igetbits(icrdat(kicrd(i)),7,12) + end if + if (irank .eq. 1 ) then + micrd(1) = kicrd(i) + else + micrd(5-irank) = kicrd(i) + end if + if (irank .eq. 2) then + levmidacc = nolev + end if +20 continue + if (levmaxacc.ne.levmidacc+1 .and. + * levmidacc.ne.levminacc+1) then + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end if + end if + rmsmin = 100000. +c +c Initialize permutation array +c + do 7 i = 1 , naccid + iperm(i) = i +7 continue +c +c Start looping over permutations +c + do 8 ip = 1 , 5041 + if (ip .ne. 1) then +c +c Work the magic algorithm to get the next permutation +c + do 1 k = naccid-1 , 1 , -1 + if (iperm(k) .le. iperm(k+1)) go to 2 +1 continue +c +c If here, we just got the last permutation, so exit the loop over permutations +c + go to 10 +2 continue + do 3 j = naccid , 1 , -1 + if (iperm(k) .le. iperm(j)) go to 4 +3 continue +4 continue + it = iperm(j) + iperm(j) = iperm(k) + iperm(k) = it + is = k+1 + do 5 ir = naccid , 1 , -1 + if (ir .le. is) go to 6 + it = iperm(ir) + iperm(ir) = iperm(is) + iperm(is) = it + is = is+1 +5 continue +6 continue + end if +c +c New we have a permutation. Take icrd values out of kicrd and put them into +c micrd in the order of the permutation +c + do 9 i = 1 , naccid + micrd(i) = kicrd(iperm(i)) +9 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false., + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +cc +cc Temporary printout +cc +c write(15,*)'perm done, rmsshift:',rmsshift +cc + if (rmsshift .lt. rmsmin) then +c +c Save this permutation, reset minrms +c + do 11 i = 1 , naccid + ipermsav(i) = iperm(i) + rmsmin = rmsshift +11 continue + end if +8 continue + print*,'Should not BEEEEEE here!' + call stop1() +10 continue +c +c Done looping, get info for the final choice +c + do 12 i = 1 , naccid + micrd(i) = kicrd(ipermsav(i)) +12 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end + subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut) + character*1 sq,chax + character*3 acsymq + character*8 noteq + character*79 notexq + logical btest,caut + sq = chax(92) + if (ihshft .eq. -107) ihshft=0 +cc +cc If main note shifted left, so shift accid. Terminate below, when acc. is done. +cc + if (ihshft .ne. 0) then +c +c Accid must be shifted horizontally +c + if (ihshft .lt. 0) then + notexq = sq//'loffset{' + ihshft = -ihshft + else + notexq = sq//'roffset{' + end if + hshft = .05*ihshft + if (hshft .lt. 1.) then + write(notexq(10:12),'(f3.2)')hshft + lnote = 12 + else + write(notexq(10:13),'(f4.2)')hshft + lnote = 13 + end if + notexq = notexq(1:lnote)//'}{'//sq + lnote = lnote+3 + else + notexq = sq + lnote = 1 + end if + if (btest(nacc,3)) then + notexq = notexq(1:lnote)//'big' + lnote = lnote+3 + end if + if (caut) then +c +c Cautionary accidental. Need to define bigcna,... in pmx.tex +c + notexq = notexq(1:lnote)//'c' + lnote = lnote+1 + end if + call accsym(nacc,acsymq,lacc) + notexq = notexq(1:lnote)//acsymq(1:lacc) + lnote = lnote+lacc + noleva = nolev + if (ivshft .ne. 0) noleva = noleva+ivshft-32 + call notefq(noteq,lnoten,noleva,ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihshft .ne. 0) then +c +c Terminate horizontal shift +c + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + return + end + subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt, + * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen, + * dotxtup,nacc) + parameter (nm=24,mv=24576) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical lowdot,dotxtup + integer*4 ihornb(nm,24),nornb(nm) + character*1 ulq(nm,9),chax + character*7 nosymq + character*8 noteq + character*79 notexq,outq + character*80 soutq + logical btest,isleft,isright,beamon + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c This subr. once produced notexq for entire chord. 10/18/97 altered to write +c chord notes as we go. 10/22/97 find range of icrd first. +c 2/25/98 moved rangefinding to precrd so done before slurs, so now +c on entry, icrd1, icrd2 define range of icrd for this chord. +c +c Set counter (for this note) for chord notes present. Set notmain=T. +c Will test for notmain=.true. in addmidi to tell whether to save pitch. +c + nmidcrd = 0 + notmain = .true. + crdacc = .false. + do 5 icrd = icrd1 , icrd2 + lnote = 0 + nolev = igetbits(icrdat(icrd),7,12) +c +c 3/8/03 save original pitch to use in midi, in case 2nds alter things. +c + nolevo = nolev +c +c Check for special situations with 2nds (see precrd). +c + if (btest(nacc,30)) then + if (nolev .eq. nolevm-1) nolev = nolevm + else if (btest(nacc,31)) then + if (nolev .eq. nolevm+1) nolev = nolevm + end if +c +c Lower dot for lower-voice notes?. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest (cannot be a rest in a chord!) +c. 5. Flag (lowdot) is set to true +c + if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then + if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then + if (btest(icrdat(icrd),26)) then +c +c Note already in movdot list. Drop by 2. +c + call setbits(icrdot(icrd),7,0, + * igetbits(icrdot(icrd),7,0)-20) + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3)) + end if + end if + end if + if (btest(icrdat(icrd),26)) then +c +c Move the dot. +c + updotc = 0.1*(iand(127,icrdot(icrd))-64) + rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64) + call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3)) + end if + isleft = btest(icrdat(icrd),23) + isright = btest(icrdat(icrd),24) +c +c Check for ornament in chord. +c + if (icrdorn(icrd) .gt. 0) then + call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq, + * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout, + * ip,0,beamon,.true.) +c +c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, +c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, +c * notcrd,beamon,iscrd) +c + call addstr(outq,lout,soutq,lsout) + end if +c +c Chord-note symbol. First check for breve +c + if (nodu .eq. 128) then + nosymq = chax(92)//'zbreve' + lsym = 7 + else +c +c Not a breve chord. Get first letters in chord-note symbol +c + if (isleft) then + nosymq = chax(92)//'l' + else if (isright) then + nosymq = chax(92)//'r' + else + nosymq = chax(92)//'z' + end if + if (nodu .ge. 64) then + nosymq = nosymq(1:2)//'w' + else if (nodu .ge. 32) then + nosymq = nosymq(1:2)//'h' + else + nosymq = nosymq(1:2)//'q' + end if + if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then + lsym = 3 + else if (.not.btest(islur,3) .or. dotxtup) then +c +c Single dot +c + nosymq = nosymq(1:3)//'p' + lsym = 4 + else +c +c Double dot +c + nosymq = nosymq(1:3)//'pp' + lsym = 5 + end if + end if + if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then +c +c Accidental and not MIDI-only. Build up bits 0-3 of nacc +c + nactmp = igetbits(icrdat(icrd),3,20) +c +c Kluge for bigness. Only means 'As' has not been issued +c + if (bacfac .ne. 1.e6) nactmp = nactmp+8 + call doacc(igetbits(icrdot(icrd),7,20)-107, + * igetbits(icrdot(icrd),6,14), +c * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) +c Get original nolev, not altered to deal with 2nds + * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12), +c * ncmid(iv,ip)) + * ncmid(iv,ip),btest(icrdat(icrd),31)) + notexq = notexq(1:lnote)//nosymq + crdacc = .true. + else + notexq = nosymq + end if + lnote = lnote+lsym +c +c Get note name (again if accid, due to possible octave jump) +c + call notefq(noteq,lnoten,nolev,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) +c +c Put in note name +c + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + if (btest(icrdat(icrd),25)) then +c +c Arpeggio signal +c +c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout) + end if + call addstr(notexq,lnote,soutq,lsout) + if (ismidi) then +c +c Here is where we collect MIDI pitch info for the chord note. By checking +c notmain, addmidi(...) knows to just compute the +c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() +c for MAIN note, will put in note codes for all chord notes + main note. +c + kv = 1 + if (ivx .gt. iv) kv=2 + nmidcrd = nmidcrd+1 + if (nmidcrd .gt. 20) then + print* + print*,'21 chord notes is too many for midi processor' + call stop1() + end if +c +c Use original saved pitch level, unaltered by 2nds logic. +c +c call addmidi(midchan(iv,kv),nolevo, + call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), + * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) + end if +5 continue + notmain = .false. + return + end + subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv, + * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout) + parameter (nm=24) +c +c Inputs are array *elements* except ihornb,nornb,ulq +c + common /commus/ musize,whead20 + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,beamon,upstem,nostem + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 udqq,chax,ulq(nm,9) + character*4 dynstrq + character*5 numpq + character*48 dyntablq,tempq + character*79 notexq + character*80 soutq + integer*4 ihornb(nm,24),nornb(nm),idynn(10) + data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/ + numdyn = 0 +c +c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values +c in idynn(1...4) +c + do 1 idyn = 1 , ndyn +c ivxtent = iand(idyndat(idyn),15) + ivxtent = iand(idyndat(idyn),15) + * +16*igetbits(idynda2(idyn),1,10) + if (ivxtent .eq. ivx) then + iptent = igetbits(idyndat(idyn),8,4) + if (iptent .eq. ip) then + numdyn = numdyn+1 + idynn(numdyn) = idyn + else if (iptent .gt. ip) then +c +c I don't think there are any more possible for this ivx,ip, so exit loop +c + go to 2 + end if +c else if (ivxtent .gt. ivx) then +c go to 2 + end if +1 continue +2 continue +c +c At this point there is a list of idyn's in idynn(1...numdyn) +c Compute level, and stem-dir'n-based horizontal tweaks +c + hoffsd = 0. +c +c Set upstem to false as default +c + upstem = .false. + if (btest(irest,0)) then +c +c It's a rest. Assume it doesn't go below the staff +c + lbot = ncm-4 + else if (.not.beamon) then + if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + if (.not.btest(ipl,10)) then + lbot = min(nolev-7,ncm-4) + else + lbot = min(minlev-7,ncm-4) + end if + end if + else + if (ulq(ivx,ibmcnt) .eq. 'u') then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + lbot = ihornb(ivx,nornb(ivx))+1 + if (lbot .eq. 1) then +c +c Kluge for non-beamed, down xtup, for which ihorb was never set. +c Assumes stem is shortened. +c + lbot = nolev-5 + end if + nornb(ivx) = nornb(ivx)+1 + end if + end if + lbot = lbot-5 + jtxtdyn1 = 1 +c +c Now ready to loop over current dyn's +c + do 3 icntdyn = 1 , numdyn + idynd = idyndat(idynn(icntdyn)) + idynd2 = idynda2(idynn(icntdyn)) + idno = igetbits(idynd,4,12) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynd2,1,10) +c +c Build the command into notex in stages. Insert name & rq'd args in order: +c +c Command name +c hpstrt, hpcend, hpdend, pmxdyn +c ivx +c X X X +c level +c X X X +c hoff +c X X X X +c d-mark +c X +c + if (idno .eq. 0) then +c +c Text-dynamic +c + notexq = chax(92)//'txtdyn' + lnote = 7 + else if (idno .le. 12) then +c +c Letter-group +c + notexq = chax(92)//'pmxdyn' + lnote = 7 + else if (fontslur) then + lnote = 7 + if (idno .eq. 13) then +c +c Start a hairpin +c + notexq = chax(92)//'hpstrt' + else if (idno .eq. 14) then +c +c End crescendo +c + notexq = chax(92)//'hpcend' + else +c +c End decrescendo +c + notexq = chax(92)//'hpdend' + end if + else +c +c Postscript hairpins +c + lnote = 7 + if (idno .eq. 13) then + notexq = chax(92)//'Icresc' + else if (idno .eq.14) then + notexq = chax(92)//'Idecresc' + lnote = 9 + else + notexq = chax(92)//'Tcresc' + end if + end if + if (idno .ge. 13) then +c +c Put in voice number +c + if (ivx .le. 9) then + notexq = notexq(1:lnote)//char(48+ivx) + lnote = lnote+1 + else if (ivx .le. 19) then + notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}' + lnote = lnote+4 + end if + end if +c +c Begin setting level +c + lbot1 = lbot + if (idno.gt.0 .and. idno.le.5) then +c +c All letters are short so raise a bit. +c + lbot1 = lbot1+1 + else if (idno .ge. 13) then + lbot1 = lbot1+2 + end if +c +c Convert so reference is bottom line +c + lbot1 = lbot1-ncm+4 + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. Save level and user-tweak before applying user tweak. +c + levdsav(ivx) = lbot1 + levhssav(ivx) = 0 + if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17) + else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then +c +c Hairpin end; Compare level with saved start level before user-tweaks +c + lbot1 = min(lbot1,levdsav(ivx)) +c +c Save pre-tweak level +c + lpretweak = lbot1 + end if +c +c Check for user-defined vertical tweak +c + if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17) +c +c Now horizontal stuff +c + hoff = hoffsd +c +c Some special horizontal tweaks +c + if (upstem .and. idno.gt.0 .and. + * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4 +c +c User-defined tweaks +c + if (btest(idynd2,0)) + * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1 + if (numdyn .gt. 1) then +c +c Horizontal-interaction-based tweaks. +c +c Cases: +c numdyn type1 type2 type3 data used +c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) +c 2 hrpnend wrd-grp - ivowg,hoh2 +c 2 hrpnend hrpnstrt - hoh2h1(1...2) +c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 +c + if (idno.gt.0 .and. idno.le.12) then +c +c Word-group, may need vertical tweak to line up. +c + lbot1 = lbot1+ivowg(idno) +c +c Protecting against hp start-stop on same note +c + else if (((fontslur.and.idno.ge.14).or.idno.eq.15) + * .and. icntdyn.lt.numdyn) then +c +c Hairpin ending, check next type +c + if ((fontslur .and. + * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. (.not.fontslur .and. + * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. + * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14)))) + * then +c +c Hairpin end then hairpin start, no words, (remember dealing with end now) +c + hoff = hoff+hoh2h1(1) + else +c +c Hairpin end then word-group, need idno for w-g to set hp offset +c + hoff = hoff + + * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12)) + end if +c +c Protecting against hp start-stop on same note +c + else if (icntdyn.gt.1 .and. idno.gt.0 .and. + * ((fontslur.and.idno.lt.14).or. + * (.not.fontslur.and.idno.lt.15))) then +c +c Hairpin start, check prior type +c + if ((fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14) + * .or. + * (.not.fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15)) + * then +c +c Hairpin end then hairpin start, (remember dealing with start now) +c + hoff = hoff+hoh2h1(2) + else +c +c Hairpin start after word-group, need idno for w-g to set hp offset +c + hoff = hoff+ + * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12)) + end if + end if + end if +c +c End of if-block for 2- or 3-way interactions. +c + if ((.not.fontslur) .and. idno.ge.13) +c +c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width +c + * hoff = (hoff+.5)*6./2.5 +c +c Position corrections all done now. Put in the level. +c + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. +c + if (.not.fontslur) then +c +c Postscript hairpin start...inset placeholder for start level. + + notexq = notexq(1:lnote)//'{ }' + lnote = lnote+5 + end if + else +c +c Insert actual level in all cases except hairpin start +c Create string with level in it +c + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Level has now been computed and stored in numpq +c Append the level +c + notexq = notexq(1:lnote)//numpq(1:lnumpq) + lnote = lnote+lnumpq + end if + if (abs(hoff) .lt. .001) then +c +c No horiz offset +c + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else +c +c Horizontal tweak +c + lform = lfmt1(hoff) + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')hoff + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + if (idno .eq. 0) then +c +c text-dynamic. Find the string and append it +c + do 4 jtxtdyn = jtxtdyn1 , ntxtdyn +c ivxip = ivx+16*ip + ivxip = ivx+32*ip + if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5 +4 continue + call printl('Abnormal stop in putdyn') + call stop1() +5 continue + ltxtdyn = lenstr(txtdynq(jtxtdyn),128) +c +c Font size based on musicsize +c + if (musize .eq. 20) then + notexq = notexq(1:lnote)//'{'//char(92)//'medtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 16) then + notexq = notexq(1:lnote)//'{'//char(92)//'normtype' + * //char(92)//'it ' + lnote = lnote+14 + else if (musize .eq. 24) then + notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 29) then + notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' + * //char(92)//'it ' + lnote = lnote+13 + end if + notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn) + * //'}' + lnote = lnote+ltxtdyn+1 +c +c Reset jtxtdyn1 just in case >1 txtdyn on same note. +c + jtxtdyn1 = jtxtdyn+1 + else if (idno .le. 12) then +c +c Letter-group dynamic. Append the letter-group command +c + id = 4*idno + dynstrq = dyntablq(id-3:id) + id = lenstr(dynstrq,4) + notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id) + lnote = lnote+1+id + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) + if ((.not.fontslur).and.idno.eq.15) then +c +c PS slurs on, hairpin is ending. Go back and set height at beginning. +c Add user-defined tweak to default level +c + lbot1 = lpretweak+levhssav(ivx) + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Construct string to search backwards for placeholder +c + if (ivx .le. 9) then + tempq = 'cresc'//char(48+ivx)//'{ }' + ltemp = 11 + else if (ivx .le. 19) then + tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }' + ltemp = 14 + else + tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }' + ltemp = 14 + end if + write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + call backfill(11,tempq,ltemp, + * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq) + end if +3 continue +c +c Shrink arrays, decrease ndyn 111109 +c + do 6 icntdyn = numdyn, 1 , -1 + do 7 jdyn = idynn(icntdyn) , ndyn-1 + idyndat(jdyn) = idyndat(jdyn+1) + idynda2(jdyn) = idynda2(jdyn+1) +7 continue + ndyn = ndyn-1 +6 continue + end + subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl, + * farend, + * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq) +c +c ip will be one LESS than current note, for way-after's before bar-end, +c It is only used to find ig. +c ig is returned to makeabar in case there's a slur that needs to be ended +c + parameter (nm=24) + logical beamon,stemup + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft, + * normsp,farend,fontslur,WrotePsslurDefaults + real*4 ptgr(37) + character*80 soutq + character*128 litq + character*79 notexq + character*20 voltxtq + character*10 figq + character*8 noteq,noteqGA + character*3 acsymq + character*1 sq,chax,udqq,ulq(nm,9) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + sq = chax(92) + isgaft = btest(ipl,29) + iswaft = btest(ipl,31) + normsp = .not. isgaft +c +c Find ig. +c + do 120 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121 +120 continue + print*,'Problem finding grace index in dograce' + stop +121 continue + ngs = ngstrt(ig) + mg = multg(ig) + wheadpt1 = wheadpt*fullsize(ivx) +c +c For way-after-graces at end of bar, must set the octave. +c + if (farend) then + noctup = 0 + if (ncm .eq.23) noctup = -2 + end if + if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then + if (listslur .eq. 16777215) then + print* + print*,'You defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Slur on fore-grace. Get index of next slur not in use, from 23 down. +c + ndxslur = log2(16777215-listslur) + + end if + if (nng(ig) .eq. 1) then +c +c Single grace. +c + if (normsp) then +c +c Anything but GA +c + call addstr(sq//'shlft',6,soutq,lsout) + niptgr = nint(ptgr(ig)) +c +c Empirical tweak for postscript. +c +C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) +c++ + if (niptgr .lt. 10) then + call addstr(chax(48+niptgr)//'{',2,soutq,lsout) + else if (niptgr .lt. 100) then + write(notexq(1:2),'(i2)')niptgr + call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout) + else + print*, + * 'Call Dr. Don if you really want grace note group > 99 pt' + stop + end if + else + call addstr(sq//'gaft{1.5}{',11,soutq,lsout) +c +c GA. Compute aftshft, for later use. +c + aftshft = grafac + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac + aftshft = aftshft*wheadpt + end if + if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then +c +c Start slur on pre-grace. No accounting needed since will be ended very soon. +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Start Postscript slur. +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print slur number, 23-ndxslur +c + lnote = 0 + if (23-ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = chax(71-ndxslur) + lnote = 1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = '{1'//chax(61-ndxslur)//'}' + lnote = 4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = 4 + end if +c if (11-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, +c * soutq,lsout) +c else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), +c * 4+lnoten,soutq,lsout) +c end if + call addstr(notexq(1:lnote)//noteq(1:lnoten), + * lnote+lnoten,soutq,lsout) + if (.not.fontslur) then +c +c Horizontal tweaks for postscript slur on single grace +c + stemup = .true. + if (upg(ig)) then +c +c Check for up-grace + down stem. Get stem direction +c + if (.not.beamon) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev,ncmidx, + * islur,nvmx,ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. tnote.gt.63 + end if + if (stemup) then + call addstr('{-.3}',5,soutq,lsout) + else + call addstr('{-.8}',5,soutq,lsout) + end if + end if + end if + if (naccg(ngs) .gt. 0) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c +c Save for checking octave shifts in GA +c + if (isgaft) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc)// + * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if + if (slashg(ig)) then + notexq = sq//'grc' + lnote = 4 + else if (mg .eq. 0) then + notexq = sq//'zq' + lnote = 3 + else + notexq = sq//'zc' + do 61 i = 2 , mg + notexq = notexq(1:i+1)//'c' +61 continue + lnote = mg+2 + end if + if (upg(ig)) then + notexq = notexq(1:lnote)//'u' + else + notexq = notexq(1:lnote)//'l' + end if + call addstr(notexq,lnote+1,soutq,lsout) + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c + if (isgaft .and. naccg(ngs).eq.0) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call addstr(noteq,lnoten,soutq,lsout) + if (slashg(ig)) call addstr(sq//'off{-'//sq// + * 'noteskip}',16,soutq,lsout) +c +c Above code needed since slashg causes spacing +c + if (slurg(ig) .and. (iswaft.or.isgaft)) then +c +c Terminate slur on single after-grace +c +c ndxslur = igetbits(ipl,4,23) + ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ngs),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +cc Print 11-ndxslur +c Print 24-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten), + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if + slurg(ig) = .false. + listslur = ibclr(listslur,ndxslur) + end if + call addstr('}',1,soutq,lsout) +c +c+++ Try to fix loss of octave with single gaft +c +c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', +c * 13+lnoten,soutq,lsout) + if (isgaft) then + itrans = 0 + do 1 i = 1 , lnotenGA + if (noteqGA(i:i) .eq. chax(39)) then + itrans = itrans+7 + else if (noteqGA(i:i) .eq. chax(96)) then + itrans = itrans-7 + end if +1 continue + if (itrans. eq. -14) then + call addstr(sq//'advance'//sq//'transpose-14',21, + * soutq,lsout) + else if (itrans .eq. -7) then + call addstr(sq//'advance'//sq//'transpose-7',20, + * soutq,lsout) + else if (itrans .eq. 7) then + call addstr(sq//'advance'//sq//'transpose7',19, + * soutq,lsout) + else if (itrans .eq. 14) then + call addstr(sq//'advance'//sq//'transpose14',20, + * soutq,lsout) + end if + end if + else +c +c Multiple grace. Put in literally. Compute beam stuff +c + sumx = 0. + sumy = 0. + sumxy = 0. + sumxx = 0. + sumyy = 0. + x = 0. + do 118 ing = ngs , ngs+nng(ig)-1 + if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac + y = nolevg(ing) + sumx = sumx + x + sumy = sumy + y + sumxy = sumxy + x*y + sumxx = sumxx + x*x + sumyy = sumyy + y*y + x = x+emgfac +118 continue + delta = nng(ig)*sumxx-sumx*sumx + em = (nng(ig)*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*gslfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/gslfac*sumx)/nng(ig) + nolev1 = nint(beta) +c +c Back up +c + notexq = sq//'settiny'//sq//'off{' + if (normsp) then + write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig) + call addstr(notexq(1:18)//'pt}',21,soutq,lsout) + finalshift = ptgr(ig) + else + aftshft = wheadpt*1.33 + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5 + write(notexq(14:17),'(f4.1)')aftshft + call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout) + end if +c +c Start the beam +c + notexq = sq//'ib' + do 119 ing = 2 , mg + notexq = notexq(1:ing+1)//'b' +119 continue + if (upg(ig)) then + notexq = notexq(1:mg+2)//'u' + else + notexq = notexq(1:mg+2)//'l' + end if + notexq = notexq(1:mg+3)//'0' +c +c Get starting note for beam +c + call notefq(noteq,lnoten,nolev1,ncm) + call addstr(notexq(1:mg+4)//noteq(1:lnoten), + * mg+4+lnoten,soutq,lsout) +c +c Put in the slope +c + if (islope .ge. 0) then + call addstr(chax(48+islope),1,soutq,lsout) + else + call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout) + end if +c +c Start a slur on multiple fore-grace +c + if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Need a tweak for postscript slur +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print 11-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten, + * soutq,lsout) + else if (23-ndxslur .lt. 2) then + call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if +c +c Put in tweak for postscript slur +c + if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout) + end if +c +c Put in first note. Call notefq again in case octave changed +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (naccg(ngs) .eq. 0) then + notexq = sq//'zqb0'//noteq(1:lnoten) + lnote = 5+lnoten + else + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten) + lnote = 4+lacc+lnoten + call notefq(noteq,lnoten,nolevg(ngs),ncm) + notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten) + lnote = lnote+5+lnoten + end if + call addstr(notexq,lnote,soutq,lsout) + do 127 ing = ngs+1 , ngs+nng(ig)-1 +c +c Skip +c + ptoff = wheadpt1*emgfac + if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac + if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff + notexq = sq//'off{' + write(notexq(6:8),'(f3.1)')ptoff + if (normsp) finalshift = finalshift-ptoff + call addstr(notexq(1:8)//'pt}',11,soutq,lsout) + if (ing .eq. ngs+nng(ig)-1) then +c +c Terminate beam if needed +c + if (upg(ig)) then + call addstr(sq//'tbu0',5,soutq,lsout) + else + call addstr(sq//'tbl0',5,soutq,lsout) + end if +c +c Terminate after slur if needed +c + if ((isgaft.or.iswaft) .and. slurg(ig)) then +c if (iswaft) ndxslur = igetbits(ipl,4,23) + if (iswaft) ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +c Print 11-ndxslur +cc Print 23-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + end if +c +c Stop slur terminator after exit from this subroutine +c + listslur = ibclr(listslur,ndxslur) + slurg(ig) = .false. + end if + end if +c +c Accidental if needed +c + if (naccg(ing).gt.0) then + call notefq(noteq,lnoten,nolevg(ing),ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ing),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc) + * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if +c +c Put in the (beamed) grace note +c + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten, + * soutq,lsout) +127 continue +c +c Terminate the grace +c +c notexq = sq//'normalnotesize'//sq//'off{' +c lnote = 20 +c notexq = '}'//sq//'off{' +c lnote = 6 + notexq = sq//'off{' + lnote = 5 + ptoff = wheadpt*emgfac + if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17)) + * ptoff = ptoff+wheadpt*accfac + if (isgaft .and. .not.iswaft) then + notexq = notexq(1:5)//'-' + lnote = 6 + ptoff = aftshft + end if + if (normsp) ptoff = finalshift + if (ptoff .lt. 9.95) then + write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff + lnote = lnote+3 + else if (ptoff .lt. 99.95) then + write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff + lnote = lnote+5 + end if + call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout) + if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout) + call addstr(sq//'resetsize',10,soutq,lsout) + end if + return + end + subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip, + * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur, + * ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. +c 12 May 2002 Create this subroutine to isolate postscript slurs/ties. +c Always set \Nosluradjust\Notieadjust +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd, + * settie,fontslur,pstie,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. +c 18 int(ndxslur/16), ditto. So this allows ndxslur>15. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +c +c Bits in isdat4 Only used for linebreak slurs +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +c +c In listslur bit ib is on if slur index ib is in use, ib=0-13. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + pstie = btest(isdat2(isdat),3) .or. idcode.eq.1 + if (btest(isdata,11)) then +c +c Turnon +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then +cc +cc Note was a rest, cannot start slur on rest. +cc +c print* +c call printl('Cannot start slur on a rest') +c call stop1() +c nolevs = ncm+5 +c end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Set level for slur starting on rest +c + if (nolevs.eq.0 .or. nolevs.gt.60) then + if (slurudq .eq. 'u') then + nolevs = ncm+2 + else + nolevs = ncm-2 + end if + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from 12 down +c + ndxslur = log2(16777215-listslur) +c write(*,'()') +c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c write(*,'(10x,B24)')listslur +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff+8 + else + ihoff = ihoff+2 + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + notexq = chax(92) + lnote = 1 +c +c Check for local adjustment default changes +c + if (btest(isdat2(isdat),26)) then + notexq = chax(92)//'sluradjust'//chax(92) + lnote = 12 + else if (btest(isdat2(isdat),27)) then + notexq = chax(92)//'nosluradjust'//chax(92) + lnote = 14 + else if (btest(isdat2(isdat),28)) then + notexq = chax(92)//'tieadjust'//chax(92) + lnote = 11 + else if (btest(isdat2(isdat),29)) then + notexq = chax(92)//'notieadjust'//chax(92) + lnote = 13 + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = notexq(1:lnote)//'islur'//slurudq + lnote = lnote+6 + else + notexq = notexq(1:lnote)//'is'//slurudq + lnote = lnote+3 + end if +c +c Prepend postscript tie switch +c + if (pstie) then + notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote) + lnote = lnote+10 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c +c noteq = notexq +c notexq = chax(92)//'dotted'//noteq + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c +c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + islhgt = nolevs+iupdn+ivoff + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Store height and staff mid level for use with LineBreakTies +c + call setbits(isdat3(isdat),8,14,islhgt) + call setbits(isdat3(isdat),8,22,ncm) +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then +c levson(midchan(iv,kv)) = nolev + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue +c +c Bugfix 070901 for slur ending on rest in 2-voice staff +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then + if (nolevs.le.2 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then +c +c Deal with \curve or \midslur. isdat is ending, j is start. +c + if (btest(isdat3(isdat),0)) then + imid = igetbits(isdat3(isdat),6,2)-32 + else + imid = igetbits(isdat3(j),6,2)-32 + end if +c +c Postscript slurs, and \midslur adjustment is needed. Invoke macro +c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: +c Abs(imid) Postscript slur type +c 1 f +c 2-3 default +c 4 h +c 5 H +c 6+ HH +c + call addstr(chax(92)//'psforts'// + * chax(48+min(abs(imid),6)),9,soutq,lsout) + end if +c +c Shift slur ending for stem on any note? +c + if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff-8 + else + ihoff = ihoff-3 + end if + end if + if (iscrd) then +c +c Shift termination for shifted notehead? +c + if (btest(isdat2(isdat),1)) then +c +c Left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c +c Switch to postscript tie +c + if (pstie) then + notexq = chax(92)//'tieforts'//notexq(1:lnote) + lnote = lnote+9 + end if +c +c Print 13-ndxslur +c 5/25/08 Allow 14 slurs +c + if (23-ndxslur .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + end if + ivoff = ivoff+ivoffinc + end if + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then + if (idcode .eq. is2n1) is1n1=0 + end if + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihoff .ne. 0) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Clear the bit from list of slurs in use +c + listslur = ibclr(listslur,ndxslur) +c +c Zero out the entire strings for start and stop +c + isdata = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + isdat4(isdat) = 0 + isdat1(j) = 0 + isdat2(j) = 0 + isdat3(j) = 0 + isdat4(j) = 0 +c +c Set midi info for slur ending +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then + icm = midchan(iv,kv) + if (slmon(icm)) then + if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then +c +c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. +c + levsoff(icm) = nolevs + settie = .true. + else + levsoff(icm) = 0 + levson(icm) = 0 + slmon(icm) = .false. + end if + end if + end if + end if + isdat1(isdat) = isdata + end if +1 continue +c +c Clear and collapse the slur data list +c + numdrop = 0 + do 2 isdat = 1 , nsdat + if (isdat1(isdat) .eq. 0) then + numdrop = numdrop+1 + else if (numdrop .gt. 0) then + 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 + end if +2 continue + nsdat = nsdat-numdrop +c call report(nsdat,isdat1,isdat2) + return + end + subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv, + * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. (5/26/02) for non-ps slurs only +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove, + * settie,fontslur,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c +c In listslur bit ib is on if slur index ib is in use, ib=0-23. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (btest(islur,1)) then +c +c 't'-slur (idcode=1) somewhere on this note. Find it, check height against +c 's'-slur (idcode=32) +c + sfound = .false. + tfound = .false. + tmove = .false. + do 5 isdat = 1 , nsdat + if (iv .eq. igetbits(isdat1(isdat),5,13) .and. + * ip .eq. igetbits(isdat1(isdat),8,3) .and. + * kv .eq. igetbits(isdat1(isdat),1,12)+1) then + if (.not.tfound) then + tfound = igetbits(isdat1(isdat),7,19).eq.1 + if (tfound) then + nolevt = igetbits(isdat2(isdat),7,19) + isdatt = isdat + if (sfound) go to 6 + end if + end if + if (.not.sfound) then + sfound = igetbits(isdat1(isdat),7,19).eq.32 + if (sfound) then + nolevs = igetbits(isdat2(isdat),7,19) + isdats = isdat + if (tfound) go to 6 + end if + end if + end if +5 continue +c +c Will come thru here if there is a t with no s, so comment out the following +c print*,'Did not find s+t-slurs in doslur' +c +6 continue + if (sfound .and. tfound) + * tmove = nolevs.eq.nolevt .and. +c +c Check if 2 starts or two stops +c + * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or. + * (.not.btest(isdat1(isdats),11).and. + * .not.btest(isdat1(isdatt),11)) ) +c +c This is a flag for later changing slur level, after we know slur dir'n. +c + end if + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + if (btest(isdata,11)) then +c +c Turnon, +c + 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() + end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (idcode.eq.1 .and. tmove) then + iupdn = 1 + if (slurudq .eq. 'd') iupdn = -1 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twenty-fifth slur, one too many!' + write(15,'(/,a)') + * 'You2 defined the twenty-fifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from ? down +c + ndxslur = log2(16777215-listslur) +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) + * ihoff = ihoff+8 + if (btest(isdat2(isdat),3)) then +c +c Tie spacing, (slur start) +c + if (slurudq.eq.'d') then + ivoff = ivoff+1 + ihoff = ihoff+8 + else if (slurudq.eq.'u') then + ivoff = ivoff-1 + if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8 +c +c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') +c + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = chax(92)//'islur'//slurudq + lnote = 7 + else + notexq = chax(92)//'is'//slurudq + lnote = 4 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c + noteq = notexq + notexq = chax(92)//'dotted'//noteq + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. idcode.eq.32) then + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue + if (nolevs.eq.0 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0)) then +c +c Deal with \curve or \midslur +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Remember, only dealing with non-ps slurs +c +c Who knows where the following line came from. Removed it 6/30/02 to +c restore behavior of non-ps slurs to old way +c if (slurudq .eq. 'd') imid = -imid +c 3/8/03 added the following +c + if (slurudq .eq. 'd') imid = -abs(imid) +c + if (btest(isdat3(isdat),1)) then + notexq = chax(92)//'curve' + lnote = 6 + else + notexq = chax(92)//'midslur' + lnote = 8 + end if + if (imid.lt.0 .or. imid.gt.9) then +c +c Need brackets +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (imid .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')imid + lnote = lnote+3 + else if (imid.lt.0 .or. imid.gt.9) then + write(notexq(lnote+1:lnote+2),'(i2)')imid + lnote = lnote+2 + else + write(notexq(lnote+1:lnote+1),'(i1)')imid + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else +c +c 1= 0 . +c Xtups are irrelevant here since they are already all in forced beams. +c Will update itnow by nodur at the END of this loop +c + ip = ip+1 + go to 11 + end if + nreal = nreal+1 + nodue(nreal) = nodur(ivx,ip) + short(nreal) = nodue(nreal).lt.16 .and. + * .not.btest(irest(ivx,ip),0) +c +c Rule out notes that have 'alone'-flag set +c + * .and..not.btest(islur(ivx,ip),18) + ipr(nreal) = ip + itr(nreal) = itnow + if (nodue(nreal) .eq. 1) then +c +c 64th gap +c + if (mod(itnow,2) .eq. 0) then +c +c Start of 32nd gap, lump with following note +c + ip = ip+1 + nodue(nreal) = 1+nodur(ivx,ip) + itnow = itnow+nodue(nreal) + else +c +c End of 32nd gap, lump with preceeding note +c + nreal = nreal-1 + nodue(nreal) = 1+nodue(nreal) + itnow = itnow+1 + end if + else + itnow = itnow+nodur(ivx,ip) + end if + go to 1 +9 continue + ir1 = 1 + itseg = lenbar/ibmrep + do 13 irep = 1 , ibmrep +c +c Set bitmaps for all shorts neighbored by a short. Each bit represents a +c span of 32nd note. maps, mapm, mape record start, full duration, and end +c of consecutive span of beamable (<1/4) notes. +c + maps = 0 + mapm = 0 + mape = 0 + itend = itseg*irep + itoff = itend-itseg + do 2 ir = ir1 , nreal + it2 = itr(ir)+nodue(ir)-2 + if (it2 .ge. itend) then + ir1 = ir + go to 14 + end if +c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal + if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or. + * (ir.lt.nreal.and.short(ir+1)))) then + ib1 = (itr(ir)-itoff)/2 + ib2 = (it2-itoff)/2 + if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or. + * min(ib1,ib2).lt.0) return +c +c Must have an odd number obe beats in a long bar. Auto-beam won't work +c + nip1(ib1) = ipr(ir) + nip2(ib2) = ipr(ir) +c +c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip +c + maps = ibset(maps,ib1) + mape = ibset(mape,ib2) + do 3 ib = ib1 , ib2 + mapm = ibset(mapm,ib) +3 continue + end if +2 continue +14 continue + if (mapm .eq. 0) go to 13 +c +c Zero out bits from forced beams +c + maps = iand(maps,not(mapfb(irep))) + mapm = iand(mapm,not(mapfb(irep))) + mape = iand(mape,not(mapfb(irep))) +c +c Compare map with template. +c + do 4 it = 1 , nummask(ibmtyp) + masknow = mask(it,ibmtyp) + if (iand(masknow,mapm) .eq. masknow) then +c +c Find least significant bit in the mask to check start time +c + mtemp = masknow + maskm = masknow + do 5 is1 = 0 , 47 + if (iand(1,mtemp) .eq. 1) go to 6 + mtemp = ishft(mtemp,-1) +5 continue +6 continue + if (iand(ishft(1,is1),maps) .eq. 0) go to 4 +c +c is1 is the bit where the beam starts. Continue shifting to +c find most significant bit in the mask to check ending time +c + do 7 is2 = is1 , 47 + mtemp = ishft(mtemp,-1) + if (iand(1,not(mtemp)) .eq. 1) go to 8 +7 continue +8 continue +c +c is2 is now the bit on which the beam ends. +c + if (iand(ishft(1,is2),mape) .eq. 0) go to 4 +c +c Did we pick out a single note from the middle of a longer sequence? +c + if (nip1(is1) .eq. nip2(is2)) go to 4 +c +c We almost have a beam. Check equality of notes if needed. +c + if (eqonly(it,ibmtyp)) then + do 10 ip = nip1(is1) , nip2(is2) + if (nodur(ivx,ip) .ne. 8) then +c +c There is a non-1/8th note in this beam. Exit if not 2 quarters +c + if (is2-is1 .ne. 15) go to 4 +c +c Beam is 2 quarters long. Check if can split in half. +c + ithalf = 0 + do 20 iip = nip1(is1) , nip2(is2) + ithalf = ithalf+nodur(ivx,iip) + if (ithalf .gt. 16) go to 4 + if (ithalf .eq. 16) go to 21 +20 continue + print*,'Problem in findbeam, please call Dr. Don' + go to 4 +21 continue +c +c Otherwise, split in half by keeping only the first half. Other half will +c be picked up later, assuming masks are listed longest first. +c + is2 = is1+7 +c +c Reset maskm (since only used part of mask), used later to zero out +c bits that contain beams +c + maskm = 0 + do 15 is = is1 , is2 + maskm = ibset(maskm,is) +15 continue + go to 16 + end if +10 continue + end if +16 continue +c +c This is a beam. If last "effective" ends on odd 64th, add 1 more +c +c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) +c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then + if (abs(amod(to(ipl2(ivx,nip2(is2))) + * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then + nip2(is2) = nip2(is2)+1 + end if + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) + call logbeam(numnew,nip1(is1),nip2(is2)) +c +c Zero out the appropriate bits so these notes don't get used again +c + mapm = iand(mapm,not(maskm)) + if (mapm.eq.0) go to 13 + maps = iand(maps,not(maskm)) + mape = iand(mape,not(maskm)) + end if +4 continue +13 continue + return + end + subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0) + parameter (nkb=3999,maxblks=4000) +c +c Compute an exponent eonk for use in the "flattened" formula for elemskips +c vs time. We must solve the eqution f = 0. Initial quess is eonk0. +c + logical gotclef + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + common /comeon/ eonk,ewmxk + eonk = eonk0 + niter = 0 +1 continue + ewmxk = f1eon(dtmax)**eonk + niter = niter+1 + esum = 0. + desum = 0. + do 2 iptr = nptr1 , nptr2 + targ = durb(iptr)/sqzb(iptr) + esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ) + detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ) + desum = desum+nnpd(iptr)*sqzb(iptr)*detarg +2 continue + f = wovera*feon(dtmin)-xelsk-esum + fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin) + * -desum + if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then + call printl( + * 'Error in findeonk. Please send source to Dr. Don') + eonk = 0. + ewmxk = 1. + return + end if + dsoln = -f/fp + if (abs(dsoln) .lt. .1*tol) return +c +c Not converged yet, try again +c + eonk = eonk+dsoln + go to 1 + end + function fnote(nodur,ivx,ip,nacc) +c +c This return the real duration of a note +c + parameter (nm=24) + integer*4 nodur(nm,200),nacc(nm,200) + logical btest + ipback = ip + if (nodur(ivx,ip) .gt. 0) then + if (ip .gt. 1) then +c +c Check if this is last note of xtup +c + if (nodur(ivx,ip-1).eq.0) then + ipback = ip-1 + go to 2 + end if + end if + fnote = nodur(ivx,ip) + return + end if +2 continue +c +c Count back to prior non zero note. Start at ip to avoid neg index if ip=1. +c Count how many doubled xtups notes there are from ip-1 to first note. +c + ndoub = 0 + do 1 ip1m1 = ipback , 1 , -1 + if (nodur(ivx,ip1m1) .gt. 0) go to 4 + if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1 +1 continue +4 continue +c +c count forward to next non-0 nodur. Start at ip in case last note of xtup. +c + do 3 iip = ip , 200 +c +c Count doubled xtup notes from ip to end. +c + if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1 + if (nodur(ivx,iip) .gt. 0) then +c fnote = nodur(ivx,iip)/float(iip-ip1m1) + fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub) + if (btest(nacc(ivx,ip),18)) then + fnote = 2*fnote + else if (btest(nacc(ivx,ip),27)) then + fnote = 1.5*fnote + else if (ip .gt. 1) then + if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote + end if + return + end if +3 continue + print*,' ' + call printl + * ('Probable misplaced barline or incorrect meter, stopping') +c call printl('Program error in fnote, send source to Dr. Don') + call stop1() + end + subroutine g1etchar(lineq,iccount,charq) + parameter(nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,issegno,isheadr,isvolt,fbon + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + character*1 charq + character*128 lineq,lnholdq +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not.endmac) then + iccount = 0 + if (.not.mplay) nline = nline+1 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return + end + subroutine g1etnote(loop,ifig,optimize,fulltrans) + parameter (nm=24,nkb=3999,mv=24576,maxblks=4000) + character*1 chax + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend, + * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt, + * stickyS + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + logical mrecord,mplay,endmac,shifton,gotclef,optimize + character*128 lineq,lnholdq + character*1 charq,dotq,dumq,durq,charlq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical novshrinktop,upslur,fontslur,ztrans, + * WrotePsslurDefaults,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + character*51 literq(3) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + common /comsize/ isize(nm) + data literq + * /'Literal TeX string cannot start with 4 backslashes!', + * 'TeX string must have <129 char, end with backslash!', + * 'Type 2 or 3 TeX string can only start in column 1!'/ + cdot = .false. +1 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') charlq = charq + if (lastchar) then + if (index('/%',charlq) .eq. 0) then + print* + print*,'WARNING:' + print*,'Last non-blank character is "',charlq,'", not "/,%"' + print*,'ASCII code:',ichar(charlq) + write(15,'(/a)')'Last non-blank character is "'//charlq// + * '", not "/,%"' + write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq) +c +c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. +c + ilbuf = ilbuf-1 + lbuf(ilbuf) = lbuf(ilbuf)+2 + bufq = bufq(1:ipbuf)//' /' + write(15,*)'appending /' + print*,'appending /' + lineq = lineq(1:iccount)//' /' + lastchar = .false. + go to 1 + end if + return + end if + if (charq .eq. ' ') then + go to 1 + else if (charq.eq.'%' .and. iccount.eq.1) then + iccount = 128 + go to 1 +c +c Replacement 1/22/12 since gfortran 4.7 with -O was choking here! +c +c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + else if (index('abcdefg',charq).gt.0 .or. + * charq.eq.'r') then +c +c This is a note/rest. gotclef is only used for checking for clef before "/" +c + if (cdot) go to 28 + if (gotclef) gotclef=.false. + idotform = 0 + numnum = 0 + plusmin = .false. +28 nnl(ivx) = nnl(ivx)+1 + if (nnl(ivx) .gt. 200) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>200 notes in line of music. Use smaller blocks!') + call stop1() + end if + dotq = 'x' +c +c Check if this is 'r ' and previous note was full-bar-pause +c + fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and. + * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar +2 call g1etchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + if (charq .eq. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one digit allowed after rest symbol "r"!') + call stop1() + end if + numnum = 2 + if (plusmin) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>2 digits in note symbol!') + call stop1() + end if + else if (durq.eq.'d') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then + iddot = 1 + iccount = iccount+1 +c +c Since we flow out, double dots won't work with other dot options +c + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, provided a number follows. +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then +c +c Backup, exit the loop normally +c + iccount = iccount-2 + go to 2 + end if + call readnum(lineq,iccount,dumq,fnum) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after 2nd +/- (shift dot)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + iccount = iccount-1 + end if + go to 2 + else if (index('<>',durq) .gt. 0) then +c +c Accidental shift +c +c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, +c * 'Expected "f", "s", or "n" before "<" or ">"!') + * 'Expected "f", "s", "n" or "A" before "<" or ">"!') + call stop1() + end if + ipm = 1 + if (durq .eq. '<') ipm=-1 + call g1etchar(lineq,iccount,durq) + if (index('123456789.0',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after (accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horizontal accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else if (index('+-',durq) .gt. 0) then + if (charq .ne. 'r') then + if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then + ipm = 1 + if (durq .eq. '-') ipm=-1 + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .gt.0) then +c +c This may be start of accidental shift, but may be octave jump; then duration +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .gt. 0) then +c +c This is an accid shift since there's a 2nd consecutive signed number. +c Check size of 1st number. +c + if (fnum .gt. 30.5) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Vertical accidental shift must be less than 31!') + call stop1() + end if + ipm = 1 + if (durq .eq. '-') ipm = -1 + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected 2nd number of accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horiz. accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else +c +c Not accid shift, reset, then flow out +c + iccount = icsav + end if + end if + end if + plusmin = .true. + if (numnum .eq. 2) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 +c +c It's a rest containing +|- . Must refer to a vertical shift. Read past. +c + else + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,dum) + iccount = iccount-1 + go to 2 + end if +c else if (index('ulare',durq) .gt. 0) then + else if (index('ularec',durq) .gt. 0) then + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change +c + call g1etchar(lineq,iccount,durq) + if (index('.0123456789:',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a number or colon here!') + call stop1() + end if + if (durq .eq. ':') then + if (.not.stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned off sticky stemshrinks without turning on!') + call stop1() + end if + stickyS = .false. + go to 2 + end if + call readnum(lineq,iccount,durq,dum) + if (dum.lt..5 .or. dum.gt.4.) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Stemlength shortening must be from .5 to 4!') + call stop1() + end if + if (durq .ne. ':') then + iccount = iccount-1 + else + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on sticky stemshrinks when already on!') + call stop1() + end if + stickyS = .true. + end if + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 2 + else if (durq .eq. 'p') then + fulbrp = charq.eq.'r' + if (.not. fulbrp) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'The option "p" only works with "r" (rest)!') + call stop1() + end if + go to 2 + else if (durq .eq. 'b') then + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "b"; I expected "rb"!') + call stop1() + else if (numnum .eq. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "r" & "b" with two numbers!') + end if + go to 2 + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'First char after "x" in xtuplet must be "1"-"9"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (fnum .gt. 99) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Xtuplet cannot have more than 99 notes!') + call stop1() + else if (index(' DFnd',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only legal characters here are " ","D","F","n"!') + call stop1() + end if +c +c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. +c + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here, number already set, but may also +c have used this before number was set. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = 1 + call g1etchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call g1etchar(lineq,iccount,durq) + end if + if (durq .eq. 'n') then +c +c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. +c + numshft = 0 +30 call g1etchar(lineq,iccount,durq) + if (durq .eq. 'f') then + go to 30 + else if (index('+-',durq) .gt. 0) then + numshft = numshft+1 + if (numshft .eq. 3) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only 2 shifts are allowed after "n" in xtup!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit or "."!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if ((numshft.eq.1 .and. snum.gt.15.1) .or. + * (numshft.eq.2 .and. snum.gt.1.51)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Shift number after "n" in xtup is out of range!') + call stop1() + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope alteration for bracket +c + call getchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'For slope adjustment, this character must be "+" or "-"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if (nint(snum) .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slope adjustment cannot exceed 15!') + call stop1() + end if + go to 30 + else if (index('123456789',durq) .gt. 0) then +c +c Unsigned integer => alternate printed number +c + call readnum(lineq,iccount,durq,snum) + if (snum .gt. 15.1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Alternate xtup number after "n" must be <16!') + call stop1() + end if + iccount = iccount-1 + go to 30 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "n" in xtup!') + call stop1() + end if + end if + ntup = nint(fnum) + do 6 itup = 2 , ntup + nodur(ivx,nnl(ivx)) = 0 + nnl(ivx) = nnl(ivx)+1 +110 call g1etchar(lineq,iccount,durq) + if (durq.eq.' ') then + go to 110 + else if (durq .eq. 'o') then +c +c Ornament in xtup. "o" symbol must come AFTER the affected note +c + call g1etchar(lineq,iccount,dumq) + if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then + if (index('fg',dumq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Fermata or segno not allowed in xtuplet!') + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + end if + call stop1() + end if + if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +29 call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') go to 29 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1, + * ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if + go to 110 + else if (index('st(){}',durq) .gt. 0) then +c +c Slur in xtup +c + iposn = 0 + numint = 0 +15 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (index('udlbfnht',dumq) .gt. 0) then + if (dumq.eq.'t' .and. durq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + go to 15 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum).gt.6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in the range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 40 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount, + * ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +40 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 15 + + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 15 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') + * iccount=iccount+1 + go to 15 + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + go to 15 + else if (dumq .ne. ' ') then + ic = ichar(dumq) + if ((ic.ge.48.and.ic.le.57) .or. + * (ic.ge.65.and.ic.le.90)) then + if (iposn .eq. 1) then + if (durq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + go to 15 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be 2nd character in slur symbol!') + call stop1() + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + end if + go to 110 + else if (index('0123456789#-nx_',durq) .gt. 0) then +c +c We have a figure. Only allow on 1st note of xtup +c + if (itup .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Figure in xtup only allowed on 1st note!') + call stop1() + else if (durq.eq.'x') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'No floating figures in xtuplets!') + call stop1() + end if + if (usefig .and. ivx.eq.1) ifig = 1 +26 call g1etchar(lineq,iccount,durq) + if (index('0123456789#-n_.:',durq) .gt. 0) then + go to 26 + else if (durq .eq. 's') then + isligfont = .true. + go to 26 + else if (durq .eq. '+') then +c +c vertical offset, must be integer then blank +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .ne. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 26 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure in xtuplet!') + call stop1() + end if + go to 110 + else if (durq .eq. 'G') then + ngr = 1 +79 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 79 + else if (index('AWulxs',charq) .gt. 0) then + go to 79 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 79 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 79 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 71 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +75 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 75 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +78 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 78 + else if (index('+-nfs',charq) .gt. 0) then + go to 78 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +71 continue + go to 110 + else if (durq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + go to 110 + else if (durq .eq. 'M') then +c +c Temporary trap until I get around putting this in pmxb +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macros not yet allowed in xtuplets!') + call stop1() + else if (durq .eq. 'X') then + call g1etx(lineq,iccount,.false.,shifton, + * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt) + go to 110 + else if (durq .eq. 'z') then +c +c Chord note in xtup. Read past for now. +c +33 call g1etchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 33 + go to 110 + else if (durq .eq. 'D') then +c +c Dynamic mark +c + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + go to 110 + else if (durq .eq. '%') then + if (iccount .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Comment must have "%" in column 1!') + call stop1() + end if + iccount = 128 + go to 110 + else if (durq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + go to 110 + end if + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 110 +c+++ + else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'[' + * .and. lineq(iccount+2:iccount+2).eq.' ') then + iccount = iccount+2 + go to 110 +c+++ + end if +c +c End of xtup options. At this point symbol can only be note or rest +c + if (index('abcdefgr',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In xtup, this character is not allowed!') + call stop1() + else if (durq.eq.'r' .and. itup.eq.ntup) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, PMX cannot end an xtuplet with a rest!') + call stop1() + end if +7 call g1etchar(lineq,iccount,durq) + if (index('2345678ulcb',durq) .gt. 0) then + go to 7 + else if (index('sfn',durq) .gt. 0) then +c +c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 7 + else if (index('+-<>',durq) .gt. 0) then +c +c May have either octave jump or shifted accid. on main xtup note +c + if (index('+-',durq).gt.0 .and. + * index('01234567890',lineq(iccount+1:iccount+1)).eq.0) + * go to 7 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 7 + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = ndoub+1 + go to 7 + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + go to 7 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal option on xtuplet note!') + call stop1() + end if + if (itup .eq. ntup-ndoub) go to 3 +6 continue +3 continue +c +c 6==End of loop for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c + if (mod(itsofar(iv),lenbar) .ne. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest must start at beginning of bar!') + call stop1() + else if (iv.eq.1.and.ibarmbr.gt.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest only OK at one time per block!') + call stop1() + end if +c +c For some purposes, pretend its one bar only +c + nodur(iv,nnl(iv)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 +c20 call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer after "rm"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mbrest = nint(fnum) + iccount = iccount-1 +c if (ichar(durq).ge.48.and.ichar(durq).le.57) then +c mbrest = 10*mbrest+ichar(durq)-48 +c go to 20 +c end if + if (nv .gt. 1) then + if (iv .eq. 1) then + mbrestsav = mbrest + else + if (mbrest .ne. mbrestsav) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must enter same multi-bar rest in every voice!') + call stop1() + end if + end if +c +c Zero out mbrestsav so can check at end of input block whether +c all voices have one +c + if (iv .eq. nv) mbrestsav=0 + end if + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "rm"!') + call stop1() + end if + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. ',') then + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (index('oL',durq) .gt. 0) then +c +c Suppress full bar rest, or look left for height +c + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o","L" options only legal for rest, not note!') + call stop1() + end if + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" or "F" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'A') then +c +c Main note accidental option +c + call getchar(lineq,iccount,durq) + if (index('o+-<>',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o",+","-","<",">" are the only legal options here!') + call stop1() + end if +c +c Need more stuff here +c + if (durq .ne. "o") then +c +c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will +c proceed to number input checking +c + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character!') + print*,'ASCII code:',ichar(durq) + call stop1() + end if +c +c End of block for note options. +c +c Set the duration +c + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) +c +c Check for double dot +c + if (iddot .eq. 1) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + iddot = 0 + end if + else if (fulbrp) then + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + fulbrp = .false. + end if + rest(ivx,nnl(ivx)) = charq.eq.'r' +c +c If inside forced beam, check if note is beamable +c + if (fbon) then + if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120 + if (nnl(ivx) .gt. 1) then + if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unbeamable thing in forced beam!') + call stop1() + end if +120 continue +c +c Get number of prior bars for later check on whether note spans bar line +c + nbb4 = itsofar(ivx)/lenbar + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (mod(itsofar(ivx),lenbar) .eq. 0) then + nbars = nbars+1 + if (shifton) barend = .true. +c +c Will check barend when 1st note of next bar is entered. +c + if (nbars .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot have more than 15 bars in an input block!') + call stop1() + end if + nib(ivx,nbars) = nnl(ivx) + if (firstline .and. lenbar.ne.lenbr1) then +c +c Just finished the pickup bar for this voice. +c + if (itsofar(ivx) .ne. lenbr0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Pickup bar length disagrees with mtrnum0!') + call stop1() + end if + lenbar = lenbr1 + itsofar(ivx) = 0 + end if + else if (barend) then + if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + barend = .false. + else if (itsofar(ivx)/lenbar .gt. nbb4) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'This note spans a bar line!') + call stop1() + end if + if (idotform.eq.1 .or. idotform.eq.3) then + call g1etchar(lineq,iccount,charq) + if (index('abcedfgr',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected note name or "r" here!') + call stop1() + end if + idotform = idotform+1 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then + call g1etchar(lineq,iccount,charq) + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected chord note name here!') + call stop1() + end if +25 call g1etchar(lineq,iccount,durq) +c if (index('dre12345678',durq) .gt. 0) then + if (index('dre12345678c',durq) .gt. 0) then + go to 25 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 25 + else if (durq .eq. 'A') then + if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n" before "A" in chord note!') + call stop1() + end if + go to 25 + else if (index('<>',durq) .gt. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then +c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n,A" before "<" or ">"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here for accidental shift!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (index('+-',durq) .gt. 0) then + if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0) + * go to 25 +c +c Number or '.' (durq) follows +/- . Get it. +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.' .and. index('1234567890', + * lineq(iccount+1:iccount+1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"." here must be followed by a digit!') + call stop1() + else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Number after +/- must follow "d,s,f,n,A"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .eq. 0) then + iccount = iccount-1 + go to 25 + end if +c +c 2nd +/- +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.') call g1etchar(lineq,iccount,durq) + if (index('1234567890',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in chord note!') + call stop1() + end if + else if (charq .eq. 'G') then + ngr = 1 +9 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 9 + else if (index('AWulxs',charq) .gt. 0) then + go to 9 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 9 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 9 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 19 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +55 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 55 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +18 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 18 +c else if (index('nfs',charq) .gt. 0) then + else if (index('+-nfs',charq) .gt. 0) then + go to 18 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +19 continue + else if (charq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. "o" symbol must come AFTER the affected note +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o" must be in same input block, after affected note!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + call stop1() + end if + if (dumq .eq. ':') then + call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after "o:"!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else if (dumq .eq. 'g') then + if (issegno) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, only one "segno" per input block!') + call stop1() + else if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'segno can only be in voice 1!') + call stop1() + end if + issegno = .true. +12 call g1etchar(lineq,iccount,dumq) + if (dumq.eq.'-' .or. + * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12 + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in segno ornament symbol!') + call stop1() + end if + else if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +22 call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after ":"!') + call stop1() + end if + go to 32 + else if (dumq .ne. ' ') then + go to 22 + end if + else if (dumq .eq. 'f') then + call g1etchar(lineq,iccount,dumq) + if (index(' d+-:',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "f" in fermata ornament symbol!') + call stop1() + end if + if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') go to 32 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if +32 continue + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + else if (index('st(){}',charq) .gt. 0) then + numint = 0 + iposn = 0 +8 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (charq.eq.'t' .and. dumq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + if (index('udltb+-fnhHps ',dumq) .eq. 0) then +c +c Check for explicit ID code. +c + ic = ichar(dumq) + if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or. + * ic.gt.90) then +c +c Not 0-9 or A-Z, so exit +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + else +c +c It is a possible ID code. Right place? +c + if (iposn .ne. 1) then +c +c Slur ID is not 2nd! +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be second character in slur symbol!') + call stop1() + else if (charq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + end if +c +c Slur ID is OK. Note it cannot be "H" at this point.. +c + go to 8 + else if (dumq .eq. 'H') then + if (iposn .eq. 1) go to 8 +c +c "H" is NOT an ID code. +c + if (.not.fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + end if + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount=iccount+1 + iposn = iposn+1 + end if + go to 8 + else if (index('fh',dumq).gt.0 .and. .not.fontslur + * .and. charq.eq.'t') then +c +c 3/9/03 Can't reshape postscript tie. +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + iposn = iposn+2 + go to 8 + end if + if (index('udltbfnh',dumq) .gt. 0) then + go to 8 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + if (fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+|-" for slur height only allowed in "s"-slurs!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 41 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +41 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1 + go to 8 + end if + else if (charq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"!') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + end if + else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or. + * index('#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + if (itsofar(ivx).eq.0 .and. + * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then +c +c Figure before first note in block +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot put figure before first note in block!') + call stop1() + end if + if (charq.eq.'x') then + indxb = index(lineq(iccount:128),' ') + if (indxb .lt. 5) then + call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot have a blank here in floating figure!') + call stop1() + end if + end if + if (usefig) ifig = 1 +5 call g1etchar(lineq,iccount,charq) + if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure!') + call stop1() + else if (charq .eq. '+') then +c +c vertical offset, must be integer, then blank +c + call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,charq,fnum) + if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 5 + else if (charq .eq. 's') then + isligfont = .true. + end if + if (charq .ne. ' ') go to 5 + else if (charq .eq. '[') then + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Started forced beam while another was open!') + call stop1() + end if + fbon = .true. +17 call g1etchar(lineq,iccount,charq) + if (index('uljhf:',charq) .gt. 0) then + go to 17 + else if (index('+-',charq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 17 + else if (charq .eq. 'm') then +c +c Forced multiplicity, next char should be 1-4 +c + call g1etchar(lineq,iccount,charq) + if (index('1234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!') + call stop1() + end if + go to 17 + else if (charq .ne. ' ') then + if (index('0123456789',charq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "[", digits must now be preceeded by "+" or "-"!') + print*,'You will have to edit older sources to meet this rqmt,' + print*,'but it was needed to allow 2-digit height adjustments.' + print*,'Sorry for the inconvenience. --The Management' + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after [!') + end if + call stop1() + end if + else if (charq .eq. ']') then + if (.not.fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced beam stop with no corresponding start!') + call stop1() + end if + call g1etchar(lineq,iccount,charq) + if (charq .eq. '-') then + if (lineq(iccount+1:iccount+2) .ne. '[ ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'Only sequence allowed here is "[ "!') + call stop1() + else + iccount = iccount+2 + end if + else if (charq .eq. '[') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else +c +c Forced beam is really ending +c + fbon = .false. + if (charq .eq. 'j') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"]" must be followed by blank, "j", "-", or "["!') + call stop1() + end if + end if + else if (charq .eq. 'D') then +c +c Dynamic mark +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"D" must not come before any notes have been entered!') + call stop1() + end if + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + else if (index('lhw',charq) .gt. 0) then +c +c Save position for later check +c + icclhw = iccount + call g1etchar(lineq,iccount,durq) + if (index('0123456789.+- ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "l", "w", or "h"!') + call stop1() + end if + isheadr = isheadr .or. charq .eq. 'h' + if (index(' +-',durq) .gt. 0) then +c +c There is a header (or lower string?) +c + if (index('+-',durq) .gt. 0) then +c +c User-defined vert offset (\internote). +c + if (charq .ne. 'h') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+" or "-" not permitted here!') + call stop1() + end if +c +c Have "h" followed by +/- . Check for digit. +c Can blow durq since not using fnum for now, but... +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a digit here!') + call stop1() + end if +c +c Have "h" followed by +/- followed by a digit. No need to get the number. +c +c call readnum(lineq,iccount,durq,fnum) + end if + if (charq .ne. 'w') then +c +c Header or lower string. +c + if (icclhw .ne. 1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"h" or "l" must be first character in line!') + call stop1() + end if +c +c Read past the next line, which has the string. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol "w" (width) must be followed by a digit!') + call stop1() + end if + else +c +c Height or width change spec. Check if at start of piece. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol must go at top of first input block!') + call stop1() + end if + call readnum(lineq,iccount,durq,dimen) +c +c Check units. Convert to points +c + if (durq .eq. ' ' .or. durq .eq. 'p') then + dimen = dimen+.5 + else if (durq .eq. 'i') then + dimen = dimen*72+.5 + else if (durq .eq. 'm') then + dimen = dimen/25.4*72+.5 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal unit; must be "p","i",or"m"!') + call stop1() + end if + if (charq .eq. 'h') then + ptheight = int(dimen) + else + widthpt = int(dimen) + end if + end if + else if (charq .eq. 'm') then +c +c Time signature change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Meter change only OK in voice 1, at start of block!') + print*,'voice number is',ivx + call stop1() + end if + newmeter = .true. + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + if (mtrnuml .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Digit 0 not allowed here!') + call stop1() +c else if (mtrdenl .eq. 1) then +cc +cc Kluge!!! +cc +c mtrdenl = 2 +c mtrnuml = 2*mtrnuml + end if + call readmeter(lineq,iccount,mtrnmp,mtrdnp) +c +c Read past printed time signature; not used in pmxa. +c + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnuml*lenbeat + mtrnuml = 0 + else if (charq .eq. 'C') then + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. +c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') + * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!') + call stop1() + end if + gotclef = .true. + else if (charq .eq. 'R') then + if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Repeats can only go in voice 1!') + call stop1() + end if +10 call g1etchar(lineq,iccount,durq) + if (index('lrdDbz',durq) .gt. 0) go to 10 + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "R" (repeat/double bar)!') + call stop1() + end if + else if (charq .eq. 'V') then +c +c Ending +c + if (iv .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Voltas are only allowed in voice #1!') + call stop1() + else if (isvolt) then + print* + print*,'*******WARNING********' + write(15,'(/,a)')'*******WARNING********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There is more than one volta in this input block.!') + print*,'This may work in a score, but WILL NOT work in parts.' + print*, + *'Safest to have only 1 volta per block, at the start of the block' + write(15,'(a)') + * 'This may work in a score, but WILL NOT work in parts.' + write(15,'(a)') + *'Safest to have only 1 volta per block, at the start of the block' + end if + isvolt = .true. + lvoltxt = 0 +11 call g1etchar(lineq,iccount,durq) + if (durq .ne.' ') then + go to 11 + end if + else if (charq .eq. 'B') then + continue + else if (charq .eq. 'P') then + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only allowed at beginning of block!') + call stop1() + end if +16 call g1etchar(lineq,iccount,durq) + if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and. + * ichar(durq).le.57)) go to 16 + if (durq .eq. 'c') then +c +c Expect a centered name, and it has to be last option +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '"') then +c +c Quoted name, go to next quote mark +c + do 35 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. '"') go to 36 +35 continue + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Missing close quote after page number command (P)!') + call stop1() +36 continue + else if (durq .ne. ' ') then +c +c Space-delimited name, look for next blank +c + do 37 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. ' ') go to 38 +37 continue +38 continue + end if + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l","r","c" or digit allowed after "P"!') + call stop1() + end if + else if (charq .eq. 'W') then + call g1etchar(lineq,iccount,durq) + if (index('.0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here!') + call stop1() + end if + call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1)) + else if (charq .eq. 'T') then +c +c Titles +c + call g1etchar(lineq,iccount,durq) + if (index('itc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must put "i", "t", or "c" after "T"!') + call stop1() + end if + ihead = ihead+2**(index('itc',durq)-1) +c +c Maybe a number after 'Tt', but ignore here. Read past string on next line. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else if (charq .eq. 'A') then +27 call g1etchar(lineq,iccount,durq) + if (index('rbsdeK',durq) .gt. 0) then + go to 27 + else if (durq .eq. 'v') then + if (ibarcnt .eq. 0) novshrinktop = .true. + go to 27 + else if (durq .eq. 'a') then + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fbar) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'i') then + call g1etchar(lineq,iccount,durq) +c +c Local interstaff correction. Set to -1. if not specifiec, or after use, +c or anytime except at top, since pmxb handles all times except at top. +c + call readnum(lineq,iccount,durq,tintstf) + if (ibarcnt .eq. 0) fintstf = tintstf + iccount = iccount-1 + go to 27 + else if (durq .eq. 'I') then +c +c Global interstaff correction. Use in place of fintstf if fintstf<0 +c + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'o') then + optimize = .true. + go to 27 + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call g1etchar(lineq,iccount,durq) + if (index('-0st',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "AS", need nv instances of "s,t,-,0"!') + call stop1() + end if + if (durq.eq.'-'.or.durq.eq.'s') then + isize(iiv) = 1 + else if (durq.eq.'t') then + isize(iiv) = 2 + end if +50 continue + go to 27 + else if (durq .eq. 'p') then + fontslur = .false. +42 continue + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,durq) + if (index('shtc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only letters allowed here are "s","h","t","c"!') + call stop1() + end if +c +c Now check for another default modifier +c + go to 42 + else if (index('lh',durq) .gt. 0) then +c +c Flags for optional linebreak ties or header specials +c + go to 42 + else + iccount = iccount-1 + end if + go to 27 + else if (durq .eq. 'N') then +c +c Override default name for a part file. Must have part number, then +c partname in quotes. Must be on line by itself, and start in column 1. +c Will only be passed thru to scor2prt. +c + if (iccount .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must start in column 1!') + call stop1() + end if + ndxquote = index(lineq,'"') + if (ndxquote.lt.4 .or. ndxquote.gt.5 .or. + * index('123456789',lineq(3:3)).eq.0 .or. + * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must be followed by inst. #, then quote!') + call stop1() + end if + ndxquote = index(lineq(ndxquote+1:128),'"') + if (ndxquote .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In "AN", file name must be in quotes!') + call stop1() + end if + iccount = 128 + else if (durq .eq. 'T') then + cstuplet = .true. + else if (durq .eq. 'R') then +c +c Get full name of normal include file; must occupy remainder of line +c + call getpmxmod(.false.,lineq(iccount+1:128)) + iccount = 128 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + if (index('l4',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l" or "4" is allowed here!') + call stop1() + end if + if (durq .eq. 'l' ) then + hoffpt = -25 + voffpt = -45 + else if (durq .eq. '4') then + ptheight = 745 + widthpt = 499 + hoffpt = -24 + voffpt = -24 + end if + go to 27 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "A" must follow one of the letters abcdeiINprRsST!') + call stop1() + end if + else if (charq .eq. 'K') then +c +c Rules and function of K command +c +c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is +c initial sig, and must be passed to pmxb because it is needed when topfile +c is called, which is before the K+n+m command is read in pmxb. Also, we +c compute and save ibrkch and newkey for each syst, accounting for key changes, +c then adjust fbar to make poenom much more accurate. +c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. +c + call g1etchar(lineq,iccount,durq) + if (index('+-i',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"K" (transpose or key change) must be followed by "+,-,i"!') + call stop1() + end if + if (durq .ne. 'i') then +c +c Normal key change and/or transposition) +c +c iccount = iccount+1 + num1 = 44-ichar(durq) +c +c num1= +1 or -1 +c + ztrans = num1.eq.-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st +/- must be followed by a number!') + call stop1() + end if +c iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = nint(fnum)*num1 + ztrans = ztrans .and. num1.eq.0 + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st number after "K" must be followed by "+,-"!') + call stop1() + end if + iccount = iccount+1 + num2 = 44-ichar(durq) + call readnum(lineq,iccount,durq,fnum) + num2 = num2*int(fnum+.1) + if (num1.eq.0 .and. .not.ztrans) then +c +c Key change, only one per block allowed +c + if (iskchb) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one key change allowed per input block!') + call stop1() + end if + iskchb = .true. + nkeys = nkeys+1 + kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0 +c +c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. +c + ibrkch(nkeys) = ibarcnt+nbars + if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1 + newkey(nkeys) = num2+idsig + else +c +c Transposition +c + fulltrans = .true. + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Transposition must be at top of first input block!') + call stop1() + end if + isig1 = num2 + idsig = isig1-newkey(1) +c +c idsig is the difference between sig after transposition, and sig in setup. +c It may alter # of accid's in key changes if there is transposition. +c + end if + else ! durq='i' +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; +c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c if (fulltrans) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot yet combine full and instrument transposition!') +c call stop1() +c end if + call GetiTransInfo(.true.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '|') then +c +c Optional bar symbol +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar line marker out of place!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + else if (charq .eq. '/') then + if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with repeated ornament still on!') + ornrpt = .false. + end if + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with sticky stemshrink still on!') + stickyS = .false. + end if + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block ended with forced beam open!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + else if (gotclef) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not enter clef at end of input block!') + call stop1() + end if + barend = .false. +c +c Perform time checks +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not divisible by lenbar!') + print*,'lenbar is ',lenbar + call stop1() + else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then + print* + print*,'# of bars in voice 1, current voice:', + * itsofar(1)/lenbar,itsofar(ivx)/lenbar + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not equal to voice 1!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new voice +c + if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0 + nbars = 0 + if (durq .eq. ' ') then +c +c New voice is on next staff +c + iv = iv+1 + ivx = iv + else +c +c New voice is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + if (ivx .gt. nm) then + write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm, + * ' lines of music at once' + call stop1() + end if + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + do 24 j = 1 , 200 + rest(ivx,j) = .false. + nacc(ivx,j) = 0 +24 continue +c +c For midi stuff, record that there is a 2nd line of music in this voice +c + if (ismidi) twoline(iv) = .true. + end if + end if + iccount = 128 + else if (charq .eq. 'S') then +c +c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"S" can only be in first input block!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit must follow "S"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + nsyst = nint(fnsyst) +14 continue + if (durq .eq. 'P') then +c +c New npages for parts. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + npages = nint(fnsyst) + go to 14 + else if (durq .eq. 'm') then +c +c Reset musize (musicsize). +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + musize = nint(fnsyst) + wheadpt = whead20*musize + go to 14 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in "S" symbol!') + call stop1() + end if + else if (charq .eq. 'L') then + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+nbars+1 + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced line break!') + call stop1() + end if + call readnum(lineq,iccount,durq,sysflb) + isysflb(nflb) = nint(sysflb) + if (nflb .gt. 1) then +c +c Check if new number is > prior one +c + if (isysflb(nflb) .le. isysflb(nflb-1)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You already forced a line break at a later line!') + call stop1() + end if + end if + if (npages .eq. 0) then + print* + print*,'WARNING! You forced a line break at line ', + * isysflb(nflb),' but npage = 0. Continue?' + read(*,'(a)') charq + if (index('yY',charq) .eq. 0) call stop1() + else if (isysflb(nflb) .gt. nsyst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced line break at line num > nsyst!') + call stop1() + else if (index(' PM',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have " ", "P", or "M" here!') + call stop1() + end if + if (durq .eq. 'P') then +c +c Forced page break here, get page number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced page break!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + nfpb = nfpb+1 + ipagfpb(nfpb) = nint(fnum) + isysfpb(nfpb) = isysflb(nflb) + if (ipagfpb(nfpb) .gt. npages) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break at page num > npages!') + call stop1() + else if (nfpb .gt. 1) then + if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break numbers must increase!') + call stop1() + end if + end if + end if + if (index(' M',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in linebreak symbol!') + call stop1() + else if (durq .eq. 'M') then + nmovbrk = nmovbrk+1 + isysmb(nmovbrk) = isysflb(nflb) + call g1etchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Vertical spacing, read past number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer required here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + go to 31 + else if (durq .eq. 'i') then +c +c Change indentation, +c + call g1etchar(lineq,iccount,durq) + if (index('.123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Decimal number required here!') + call stop1() + end if +c +c fracsys was initialized in block data to all 0.'s +c + call readnum(lineq,iccount,durq,fracsys(nmovbrk)) + go to 31 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have "+" or "-" after "r" as movement break option!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iorig in original list of instruments. +c + nv = 0 + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number, get next two characters +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')ninow + else +c +c durq is a single digit number for noinow +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq// + * ' at movement break!') + call stop1() + end if + ninow = ichar(durq)-48 + end if + if (ninow.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New number of instruments must be <= original!') + call stop1() + end if + do 63 iinow = 1 , ninow + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal 2-digit instrument number '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')iorig + else +c +c durq is a single digit number for iorig +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal instrument number '//durq// + * ' at movement break!') + call stop1() + end if + iorig = ichar(durq)-48 + end if + if (iorig .gt. noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New instrument number must be <= original noinst!') + call stop1() + end if + nv = nv+nsperi(iorig) +63 continue + do 61 iiv = 1 , nv +c +c Get clef names +c + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!') + call stop1() + end if +c +c Initialize new voices +c + nvmx(iiv) = 1 + ivmx(iiv,1) = iiv + itsofar(iiv) = 0 + nnl(iiv) = 0 + do 62 j = 1 , 200 + rest(iiv,j) = .false. +62 continue +61 continue +c +c Loop back up, this might not be last option in M +c + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after Movement break symbol!') + call stop1() + end if + if (fracsys(nmovbrk) .lt. 0.001) then +c +c Since fracsys was not explicitly set, set it to prior value. +c + if (nmovbrk .eq. 1) then + fracsys(nmovbrk) = fracindent + else + fracsys(nmovbrk) = fracsys(nmovbrk-1) + end if + end if + end if +c +c Just before exiting if-block for forced line breaks, set counter to use when +c dealing with vertical space calcs +c + nistaff(nflb) = nv-1 + else if (charq .eq. 'F') then + usefig = .false. + else if (charq .eq. 'X') then + call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1, + * udsp(ibarcnt+nbars+1),wheadpt) + else if (charq .eq. 'I') then +c +c MIDI settings. +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MIDI stuff only allowed at start of block!') + call stop1() + end if + if (nv .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry but MIDI does not work with more than 15 voices!') + call stop1() + end if + ismidi = .true. + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.true.) + else if (charq .eq. 'M') then + call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx, + * nline) + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + else + print*,'ASCII code:',ichar(charq) + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character is not allowed here!') + print*,'ASCII code:',ichar(charq) + call stop1() + end if + return + end + subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey,npages,nsyst,musize,bottreb) + parameter(nm=24,maxblks=4000) + character*65536 bufq + character*1 chax + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*128 lineq + logical lastchar,issegno,isheadr,isvolt,fbon,bottreb, + * newway + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 +c +c Get the first line +c + iccount = 0 + nline = 1 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') then + nline = nline+1 + go to 9 + end if + if (lineq(1:3) .eq. '---') then +c +c Have TeX input until next line that starts with '---' +c +3 nline = nline+1 + call getbuf(lineq) + if (ilbuf .gt. nlbuf) go to 1 + go to 2 +1 print*,'You did not terminate type 0 TeX input with "---"' + call stop1() +2 continue + if (lineq(1:3) .ne. '---') go to 3 +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq and nline are first non-TeX lines. +c + nv = nint(readin(lineq,iccount,nline)) + if (nv .gt. nm) then + write(*,'(1x,a46,i3)') + * 'In setup data, number of voices cannot exceed',nm + call stop1() + end if + noinst = nint(readin(lineq,iccount,nline)) + if (noinst .gt. nv) then + write(*,'(a)') + * 'In setup data, cannot have more instruments than staves' + call stop1() + end if + newway = noinst.le.0 + if (newway) noinst = -noinst + do 10 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if +10 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge!!! +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then + write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8' + call stop1() + end if + xmtrnum0 = readin(lineq,iccount,nline) + newkey = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) + if (fracindent .ge. 1.) then + write(*,'(a)')'In setup data, fracindent must be <1' + call stop1() + end if + if (npages .gt. nsyst) then + print*,'Error in input file: npages > nsyst' + call stop1() + else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then + call printl('Musicsize must be 16, 20, 24, or 29') + call stop1() + end if +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , abs(noinst) +5 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 6 + do 7 iv = 1 , nv +c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then + if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then + call errmsg(lineq,iv,0, + * 'There should be a clef symbol here!') + call stop1() + end if +7 continue + if (lineq(nv+1:nv+1) .ne. ' ') then + call errmsg(lineq,nv+1,0, + * 'There should be a blank here!') + call stop1() + end if +c +c Set flag if voice 1 is treble, since it affects vertical spacing +c + bottreb = lineq(1:1).eq.'t' +c +c Mext non-comment line has path name +c +8 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 8 + lpath = index(lineq,' ')-1 + if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then + call errmsg(lineq,lpath,0, + * 'Last character of pathname is not "/",":", or "' + * //chax(92)//'"!') + call stop1() + end if + return + end + subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c + logical notxtup,shifton,number,btest + character*128 lineq + character*1 charq,dumq + number = .false. + nPBSc = 0 +1 call g1etchar(lineq,iccount,charq) + if (index('PBS:',charq) .gt. 0) then +c +c Continue checking here even if "P". +c + ipbsc = index('PBS:',charq) + if (btest(nPBSc,ipbsc)) then + call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!') + call stop1() +c else if (.not.notxtup .and. ipbsc.gt.2) then +c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') +c call stop1() + end if + nPBSc = ibset(nPBSc,ipbsc) + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (index('+-',charq) .gt. 0) then + call g1etchar(lineq,iccount,dumq) + if (index('.0123456789',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibar,'Expected a number here!') + call stop1() + end if + end if + call readnum(lineq,iccount,dumq,fnum) + if (charq.eq.'-') fnum = -fnum + if (dumq .ne. 'p') then + iccount = iccount-1 + fnum = fnum*wheadpt + end if + go to 1 + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!') + call stop1() + end if +c +c Done with parsing. Other checks +c + if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then + call errmsg(lineq,iccount-1,ibar, + * 'Cannot have both "P" and "B" or "S" and ":"!') + call stop1() + end if + if (btest(nPBSc,4)) then + if (number) then + if (shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Started a group shift without stopping prior one!') + call stop1() + else + shifton = .true. + end if + else + if (.not. shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Ended a group shift without starting one!') + call stop1() + else + shifton = .false. + end if + end if + end if +c +c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) +c + if (iand(nPBSc,26).eq.0) udsp = udsp+fnum + if (.not.number .and. .not.btest(nPBSc,4)) then + call errmsg(lineq,iccount-1,ibar, + * 'Must have either a number or a colon in "X" symbol!') + call stop1() + end if + return + end +c integer*4 function mytime() +c CHARACTER(10) tq +c CALL DATE_AND_TIME(TIME=tq) +c read(tq,'(2i2,f6.3)')ih,im,ts +c mytime = 1000*(ts+60*(im+60*ih)) +c return +c end + subroutine getbuf(lineq) + parameter (maxblks=4000) + character*(*) lineq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) + ipbuf = ipbuf+lbuf(ilbuf) + ilbuf = ilbuf+1 + return + end + subroutine getchar(lineq,iccount,charq) + parameter (nm=24) +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,equalize,stickyS + character*1 charq,rptfq1,rptfq2 + character*128 lineq,lnholdq + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not. endmac) then + iccount = 0 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call mrec1(lineq,iccount,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return +999 continue + lastchar = .true. + return + end + subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount) + parameter (nm=24) + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 durq,chax + character*4 dynsymq + character*128 lineq +c +c Get info for dynamic mark. Enter after getting "D", iccount sits on "D" +c Bits in idyndat are as follows +c 00-03 ivx +c 04-11 ip +c 12-15 code for type of mark +c 0 => arbitrary text +c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff +c If (.not. fontslur) +c 13 => hairpin start, 14,15 => <,> (ending) +c else +c 13 < start, 14 > start, 15 ending +c end if +c 16 flag for vertical offset +c 17-23 vertical offset + 64 , \internote +c 31 Hairpin start (0), stop (1) +c +c idynda2 +c +c 00 flag for horizontal offset +c 01-09 (horizontal offset)/10 + 25.6 notehead widths +c 10 5th bit for ivx (5/15/10) +c + irest = ibset(irest,26) + ndyn = ndyn+1 + idyn = ivx + idynda2(ndyn) = 0 + if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1) + call setbits(idyn,8,4,ip) + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c text-dynamic +c + ntxtdyn = ntxtdyn+1 + iend = iccount+index(lineq(iccount+2:128),'"')+2 + txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) +c +cc Store ivx, ip in bits 0-11 +c Store ivx, ip in bits 0-12 +c +c ivxiptxt(ntxtdyn) = idyn + ivxiptxt(ntxtdyn) = ivx+32*ip + ipm = index('- +',lineq(iend:iend)) + idno = 0 + else +c +c Word-group or hairpin +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) +c +c Exit the loop at first blank, "+", or "-" +c + if (ipm .gt. 0) go to 2 +1 continue +2 continue + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ', + * dynsymq)+3)/4 +c +c Save for later down +c + idno1 = idno + end if +c +c Set flag to check level later if in beam +c + iornq = ibset(iornq,23) + if (idno.ge.14) then +c +c Hairpin here. Check if opposite type from one that's already on +c + if (idno.eq.14.and.btest(listdecresc,ivx) .or. + * idno.eq.15.and.btest(listcresc,ivx)) then + call printl(' ') + call printl('Started one kind of hairpin while other is on') + call stop1() + end if +c +c Start or stop? +c + if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then +c +c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. +c + if (.not.fontslur) idno = 15 + else if (fontslur) then +c +c Start of font slur +c + idno = 13 + else +c +c Start of postscript slur +c + idno = idno-1 + end if + end if +c +c Now that we used list[de]cresc, update +c + if (idno .ge.13) then + if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then +c +c Something's ending +c + if (btest(listcresc,ivx)) then +c +c It's a cresc! +c + listcresc = ibclr(listcresc,ivx) + else + listdecresc = ibclr(listdecresc,ivx) + end if + else +c +c Something's starting +c + if (idno1 .eq. 14) then +c +c It's a cresc! +c + listcresc = ibset(listcresc,ivx) + else + listdecresc = ibset(listdecresc,ivx) + end if + end if + end if + call setbits(idyn,4,12,idno) + iccount = iend + if (ipm .ne. 2) then +c +c There is a vertical shift +c + idyn = ibset(idyn,16) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + call setbits(idyn,7,17,(ipm-2)*idno+64) + ipm = index('- +',durq) + if (ipm .ne. 2) then +c +c There is a horizontal shift +c +c idynda2(ndyn) = ibset(idyn,23) + idynda2(ndyn) = ibset(idynda2(ndyn),0) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256) + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + idyndat(ndyn) = idyn + return + end + subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig, + * itsofar,nodur,figq,ivupfig,nfigs) + logical isfig + character*1 charq + character*10 figq + character*128 lineq +c +c As of 11/26/08, trapped extra figures in getnote, so no need here. +c +c if (ivx .gt. 2) then +cc +cc Read past the figure +cc +c6 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') go to 6 +c return +c end if + nfigs = nfigs+1 + ivupfig = 0 + itoff = 0 + if (charq .eq. 'x') then +c +c Floating figure. +c + call getchar(lineq,iccount,charq) + read(charq,'(i1)')noff + call getchar(lineq,iccount,charq) + read(charq,'(i1)')loff + itoff = noff*ifnodur(loff,'x') + call getchar(lineq,iccount,charq) + else +c +c Figure on a note +c + isfig = .true. + end if + itfig = itsofar+itoff-nodur + lfig = 1 + figq = charq +5 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') then + if (index(' +',charq) .eq. 0) then + figq = figq(1:lfig)//charq + lfig = lfig+1 + go to 5 + else if (charq .eq. '+') then +c +c Get vertical offset for figure. Next character after number has to be blank. +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ivupfig = nint(fnum) + end if + return + end + subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + parameter (nm=24) + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg + character*1 charq,durq + character*20 voltxtq + character*128 lineq,litq + integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm), + * ndlev(nm,2) + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c + 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,iTransAmt(instno(iv))) + 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,iTransAmt(instno(iv)))-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 + return + end + subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) +cccccccccccccccccccccccc +cc +cc GetiTransInfo.for +cc +cccccccccccccccccccccccc +c +c Called from both g1etnote and getnote, after first 'i' in Ki[...] +c On entry, iccount points to last char retrieved, which is 'i' +c +c From1: locgical, true if called from g1etnote +c ibarcnt: tells whether to set EarlyTransOn to true. +c EarlyTransOn set false in blkdata, true here, back to false in topfile. +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; +c LaterInstTrans from getnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c iTransAmt stored as fn of instrument #, not like iTransKey which is +c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This +c simplifies use of iTransAmt for all calls to ifnolev. +c + parameter (nm=24) + logical From1 + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans,store + character*128 lineq + character*1 durq + durq = 'x' ! Can't initialize in declaration stmt, only works once. + if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0 + store = (EarlyTransOn.and.ibarcnt.eq.0) .or. + * (ibarcnt.gt.0.and..not.From1) + LaterInstTrans = .not.From1 .and. ibarcnt.gt.0 + if (store) nInstTrans = 0 +1 continue + if (durq .eq. ' ') return + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be an instrument number here!') + call stop1() + end if + if (store) nInstTrans = nInstTrans+1 + call readnum(lineq,iccount,durq,fnum) + instn = nint(fnum) + if (instn.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Instrument number out of range!') + call stop1() + end if + if (store) iInstTrans(nInstTrans) = instn +c +c durq is +/- following inst # (for iTransAmt), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after instrument number must be "+,-"!') + call stop1() + end if + itramt = 44-ichar(durq) ! +1/-1 for itramt + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a transposition amount here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransAmt(instn) = nint(fnum)*itramt +c +c durq is +/- following iTransAmt (for iTransKey), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after transposition amount must be "+,-"!') + call stop1() + end if + ikey = 44-ichar(durq) ! +1/-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a key indicator here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransKey(nInstTrans) = nint(fnum)*ikey +c +c durq is now 1st character after iTransKey, should be either 'i' or ' ' +c + if (durq.ne.'i'.and.durq.ne.' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be blank or "i" here!') + call stop1() + end if + go to 1 + end + subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,first) +c +c Use this from both pmxa and pmxb to input and check midi data. "first" tells +c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause +c things to be written immediately into the midi storage buffers. +c + parameter (nm=24,mv=24576) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c + integer*2 mmidi,midinum(26) + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + character*1 durq + character*2 instq + character*128 lineq + logical first + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Instrument codes +c + data midinum + * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67, +c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX +c + * 68,69,71,72,74,75, 8,55 / +c bsXobXbaXclXflXreXctXvo +c +1 call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Tempo in beats ber minute +c + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the pause!') + call stop1() +c else if (mmacrec) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot change MIDI tempo while recording a MidiMacro!') +c call stop1() + end if + call readnum(lineq,iccount,durq,qpm) + iccount = iccount-1 + if (.not.first) then + call midievent('t',nint(qpm),0) + gottempo = .true. + end if + go to 1 + else if (durq .eq. 'p') then +c +c Insert a pause. pausemid = pause in 1/4's +c + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here for the pause!') + call stop1() + end if + call readnum(lineq,iccount,durq,pausemid) + iccount = iccount-1 + if (.not.first) then +c +c Compute a meter for the pause. This is only to keep MidiNotate on track. +c Round pause to nearest 16th. Let denominator always be 16. +c + numb16 = nint(pausemid*4) + call midievent('m',numb16,16) +c +c Put in pausemid beats of rest +c + do 3 icm = 0 , numchan-1 + call addmidi(icm,0,0,0,4.*numb16,.true.,.false.) +3 continue + miditime = miditime+nint(240*pausemid) +c +c Restore meter +c + call midievent('m',mtrdenl*lenbar/64,mtrdenl) + end if + go to 1 + else if (durq .eq. 'i') then +c +c Instrument numbers or letters. Expect nv of them. +c + do 2 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (ichar(durq) .gt. 96) then +c +c It's a lowercase letter. Get another, find corr. instrument #. +c + instq(1:1) = durq + call getchar(lineq,iccount,durq) + instq = instq(1:1)//durq + iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'// + * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3 + if (iname .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unrecognized 2-letter midi instrument name!') + call stop1() + end if + midinst(ivx) = midinum(iname)-1 + else +c +c Expect a number, followed by ":" if that is followed by another number. +c I.e., if after call to readnum, durq is not ":", it must be either blank +c or next instrument letter. +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi instrument number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midinst(ivx) = nint(fnum)-1 + if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi instrument number must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 + end if +2 continue + go to 1 + else if (durq .eq. 'v') then +c +c Get volumes for each instrument. Expect nv of them. +c Follow same pattern as for insttrument numbers above. +c + do 7 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi velocity number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midivel(ivx) = nint(fnum)-1 + if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi velocity must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +7 continue + go to 1 + else if (durq .eq. 'b') then +c +c Get balance for each instrument. Expect nv of them. +c Follow same pattern as for instrument numbers above. +c + do 8 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a balance number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midibal(ivx) = nint(fnum)-1 + if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi balance must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +8 continue + go to 1 + else if (durq .eq. 'T') then +c +c Get transposition for each instrument. Expect nv of them. +c Follow similar pattern as above, but separator is +|-. +c + do 9 ivx = 1 , nv + call getchar(lineq,iccount,durq) + ipm = index('-+',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" for midi transposition here!') + call stop1() + end if + ipm = 2*ipm-3 + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + miditran(ivx) = ipm*nint(fnum) +c if (mod(miditran(ivx),12).ne. 0) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Midi transposition limited to multiples of 12!') +c call stop1() +c end if + iccount = iccount-1 +9 continue + go to 1 + else if (durq .eq. 'g') then + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the midi gap!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mgap = nint(fnum) + iccount = iccount-1 + go to 1 + else if (durq .eq. 'M') then +c +c MidiMacros +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'R') then +c +c Start recording +c + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to record a MidiMacro while already recording!') + call stop1() + end if + mmacrec = .true. + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (immac .gt. 20) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MidiMacro ID cannot exceed 20!') + call stop1() + end if +c +c Save the start time +c + mmactime(immac) = miditime + do 4 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then +c +c Adjust if there's a rest at end of prior section. Insert dummy turnoff. +c (This causes two turn-offs in a row, which testmidi sees as an error). +c +c Before: section1 ------rest------- section2(to be recorded) +c After: section1 rest1 now rest2 section2(recorded) +c + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacstrt(icm,immac) = imidi(icm)+1 +4 continue + end if + go to 1 + else if (index('123456789P',durq) .eq. 0) then +c +c End recording; close the open macro. Get immac from common. +c + if (.not.mmacrec) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You tried to end a MidiMacro before starting one!') + call stop1() + end if + mmacrec = .false. + iccount = iccount-1 + if (.not.first) then +c +c Save the macro duration +c + mmactime(immac) = miditime-mmactime(immac) + do 5 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track if needed. +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacend(icm,immac) = imidi(icm) +5 continue + end if + if (durq .ne. ' ')go to 1 + else if (durq .eq. 'P') then +c +c Play Back a Macro +c + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to play a MidiMacro before ending recording!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (mmactime(immac) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a MIDI macro before recording it!') + call stop1() + end if + do 6 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0. + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + end if + end if + msecend(icm,nmidsec) = imidi(icm) + msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac) + msecend(icm,nmidsec+1) = mmacend(icm,immac) + msecstrt(icm,nmidsec+2) = imidi(icm)+1 +6 continue + nmidsec = nmidsec+2 +c +c Update running time +c + miditime = miditime+mmactime(immac) + lasttime = miditime + end if + go to 1 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MidiMacro sub-command!') + call stop1() + end if + else if (durq .eq. 'd') then + debugmidi = .true. + go to 1 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MIDI input data!') + call stop1() + end if + if (.not.gottempo .and. .not.first) then +c +c If no tempo is set on first call on the pmxb pass, then set it +c + call midievent('t',96,0) + gottempo = .true. + end if + return + end + subroutine getnote(loop) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*10 figq + character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax + logical beamon,firstgulp,figbass,figchk,isfig + character*60 cheadq + character*120 instrq,titleq,compoq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp, + * was2,nobar1,quoted,isbj2,stickyS, + * OptLineBreakTies,HeaderSpecial + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /combc/ bcspec + common /comas3/ ask(2500),iask,topmods +c +c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined +c ivx is current ivmx, and is the index for all notes, acc's etc. +c + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comtrans/ cheadq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + common /comclefq/ clefq(nm) + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + character*128 txtdynq + logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur, + * fontslur,WrotePsslurDefaults + character*128 lineq,lnholdq + character*80 headrq, lowerq + character*79 inameq + character*59 hdlndq + character*20 voltxtq + character*1 charq,dotq,durq,ulfbq,dumq + logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved, + * topmods,headlog,btest,sluron,cdot,equalize + character*24 tempq + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1, + * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3 + logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3 + common /combibarcnt/ ibarcnt + cdot = .false. +1 call getchar(lineq,iccount,charq) + if (lastchar) return + if (charq .eq. ' ') go to 1 + if (charq .eq. '%') then +c +c Check for a bar number format: +c + if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and. + * index('bB1234567890',lineq(3:3)).gt.0) then + if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128)) + end if + iccount = 128 + go to 1 + end if +c +c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' +c + if (rptprev) then + rptnd1 = charq .eq. '/' + rptprev = .false. + end if +c +c Repeat at end of a piece +c + if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + * charq.eq.'r') then + if (cdot) go to 28 +c +c This is a note/rest. +c + idotform = 0 + numnum = 0 +c +c If start of line of music, set pitch from previous +c + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv) +c +c notcrd is used to tell if orn. goes on main note or chord note +c +c notcrd = .true. !Move dow. Was not observed if dotted shortcut. +c +c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. +c +28 continue +c +c Moved this from just above, 2 Feb 02 +c + notcrd = .true. + nnl(ivx) = nnl(ivx)+1 + if (ornrpt) then +c +c Replicate ornament bits, also bit 23 for beam handling if chord. +c + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + if (stickyS) then +c +c Grab stemlength shortening parameters from prior note +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + end if + if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then +c +c Doing auto forced beams, and period has been set, so check if this note +c starts a period. +c +c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Start a forced beam here +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + end if + end if + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) + dotq = 'x' + if (charq.eq.'r') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (btest(irest(ivx,nnl(ivx)),0)) then +c +c Rest stuff. First check if previous note was full-bar-pause +c + if (lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1) then + if (btest(islur(ivx,nnl(ivx)-1),19)) + * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + end if +c +c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 +c for voice a or b. Set a-types at 0 as encountered and adjust later +c after '//'. (Override heights will be set to 100+offset) +c + if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if +2 call getchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + ioct = ic-48 + numnum = 2 + go to 2 + else + print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx) + call stop1() + end if + else if (durq .eq. 'd') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then +c +c Double dot. +c + iccount = iccount+1 + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3) + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0) + * go to 2 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19) + call getchar(lineq,iccount,durq) + ndotmv(ivx) = ndotmv(ivx)+1 + iccount=iccount+1 + call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx))) + if (durq .eq. '-') + * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx)) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx))) + if (dumq .eq. '-') + * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx)) + else + rtdot(ivx,ndotmv(ivx)) = 0. + end if + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. 'p') then +c +c Full-bar rest as pause +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'b') then +c +c Blank rest +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Accidental +c + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accidental has been set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Repeated accid, so must be double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + go to 2 + else if (durq .eq. 'i') then +c +c Set flag for MIDI-only accidental. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + go to 2 + else if (index('+-<>',durq) .gt. 0) then + ipm = index('- +',durq)-2 + if (.not.btest(irest(ivx,nnl(ivx)),0)) then +c +c A note, not a rest. +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (moved) go to 2 +c +c Octave jump with a note +c + if (numnum .lt. 2) then + lastlev = lastlev+ipm*7 + else + ioct = ioct+ipm*1 + end if + go to 2 + else +c +c Override default height of a rest +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (lineq(iccount-1:iccount-1) .eq. '.') then +c +c Kluge in case there is a shortcut ".". It will have been sucked up by +c readnum. (Same doesn't hold for ",") +c + iccount = iccount-2 + go to 2 + end if + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) +c +c There may be more characters for this rest +c + iccount = iccount-1 + go to 2 + end if + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. Set flag on this note. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28) +c +c Next input will be digit +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ntup = nint(fnum) + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here xtup number already set but may also +c have this command before. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = 1 + call getchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + end if +c +c Only other possibilities here are ' ' or 'n' +c + if (durq .eq. 'n') then +c +c Alter xtup number +c + if (lineq(iccount+1:iccount+1) .eq. ' ') then +c +c If the only modifier is 'n', cancel the number +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) + else + numshft = 0 +30 call getchar(lineq,iccount,durq) + if (durq .eq. 'f') then +c +c Flip up-down-ness +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14) + go to 30 + else if (index('+-',durq) .gt. 0) then +c +c Vertical or horiz shift +c + numshft = numshft+1 + iofforn = 1 + if (durq .eq. '-') iofforn = -1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + if (numshft .eq. 1) then +c +c Vertical shift +c + iofforn = iofforn*nint(xofforn) + 16 +c +c Turn on bit 1; set bits 2-6 to iofforn +c + irest(ivx,nnl(ivx)) = + * ior(irest(ivx,nnl(ivx)),2+4*iofforn) + else +c +c Horizontal shift +c + iofforn = iofforn*nint(xofforn*10)+16 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7) + call setbits(irest(ivx,nnl(ivx)),5,9,iofforn) + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope adjustment for bracket +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4) + call getchar(lineq,iccount,durq) + iofforn = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + iofforn = nint(iofforn*xofforn+16) + call setbits(mult(ivx,nnl(ivx)),5,5,iofforn) + else if (index('123456789',durq) .gt. 0) then +c +c Replacement printed number +c + call readnum(lineq,iccount,durq,xofforn) + call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn)) + iccount = iccount-1 + go to 30 + end if + end if + end if +c +c Set note level of 1st note of xtup, provided not a rest +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + end if + do 40 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on starting note of xtuplet +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +40 continue + numnum = 0 + nodur(ivx,nnl(ivx)) = 0 + do 6 itup = 2 , ntup + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + nnl(ivx) = nnl(ivx)+1 + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) +7 call getchar(lineq,iccount,charq) + if (charq .eq. ' ') then + go to 7 + else if (charq .eq. '%') then + iccount = 128 + go to 7 + else if (charq .eq. 'o') then +c +c Ornament in xtuplet. "o" symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)-1) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1), + * iornq(ivx,0),ornrpt,noffseg, + * nnl(ivx)-1,ivx,.false.,notcrd,nole) + go to 7 + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx)-1 + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detected preslur in xtuplet loop, non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') islur(ivx,nnlivx) = + * ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + go to 7 + else if (charq .eq. 'G') then +c +c Kluge to get grace in xtup at right location +c + nnl(ivx) = nnl(ivx)-1 + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + nnl(ivx) = nnl(ivx)+1 + go to 7 + else if (charq .eq. sq) then + call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount) + go to 7 + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c Figure. Must come AFTER the first note of xtup +c + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx), + * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) + go to 7 + else if (charq .eq. 'X') then + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)), + * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx, + * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur, + * dotq,ndoub) + go to 7 + else if (charq .eq. 'z') then +c +c Chord note in xtup. Goes with *prior* note. +c + notcrd = .false. + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx)-1 + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +34 call getchar(lineq,iccount,durq) +c +c When chord note is done, will get ' ', making ndx=0, so go past this block +c + ndx = index('fsn+-<>12345678reic',durq) + if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 19) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)-1) = + * ibset(iornq(ivx,nnl(ivx)-1),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14, + * igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20, + * igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)-1) = + * ibset(irest(ivx,nnl(ivx)-1),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else +c +c must be a number, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 34 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 41 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on chord note in xtup +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Following lines copied from loop for non-xtup, chord note, preslur +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0) + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0) + isdat2(nsdat-npreslur+1) = + * ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +41 continue + go to 7 + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)-1),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx)-1 + ArpShift(NumArpShift) = fnum + end if + go to 7 + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1), + * iornq(ivx,nnl(ivx)-1),lineq,iccount) + go to 7 +c+++ + else if (charq .eq. ']') then +c +c Multiplicity up-down, must have '][ ' +c + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20) + iccount = iccount+2 + go to 7 +cc+++ + end if +c +c End of loop for xtup options. If here, charq must be a (non-crd) note name. +c or rest +c + if (charq .eq. 'r') then +c +c Rest in xtup +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then + call getchar(lineq,iccount,durq) + if (durq .eq. 'b') then +c +c Blank rest in middle of xtup +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + else +c +c Override height of embedded xtup rest +c + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) + iccount = iccount-1 + end if + else if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if + notcrd = .true. +8 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then + if (index('+-<>',durq) .gt. 0) then +c +c Accidental horizontal shift +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (.not.moved) then + if (durq.eq.'+') then + lastlev = lastlev+7 + else if (durq.eq.'-') then + lastlev = lastlev-7 + end if + end if + else if (index('fsn',durq) .gt. 0) then + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accid set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Symbol must be repeated, so it's a double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + else if (durq .eq. 'i') then +c +c Set flag for midi-only accidental +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (index('ul',durq) .gt. 0) then +c +c Force stem direction for non-beamed xtup note +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + else if (durq .eq. 'e') then +c +c Left-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then +c +c Right-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = ndoub+1 + else if (durq .eq. 'd') then +c +c Dotted xtup note +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + else +c +c Must be an octave number +c + lastlev = ifnolev(charq,ichar(durq)-48 + * ,iTransAmt(instno(iv))) + end if + go to 8 + end if + if (itup .lt. ntup) then +c +c Last note is handled *after* flowing out of the xtup if block, but still +c within block for a note-rest. Set note level now (rest already done). +c Could have problem here if rests & doubled notes are combined in xtup, +c since might exit the loop at the wrong place. Worry about it later. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + lastlev = lastlev-3+mod(ifnolev(charq,10, + * iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + nodur(ivx,nnl(ivx)) = 0 + do 42 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on internal xtup note +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +42 continue + end if + if (itup .eq. ntup-ndoub) go to 12 +6 continue +12 continue + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if +c +c End of if-block for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c For some purposes, pretend its one bar only +c + nodur(ivx,nnl(ivx)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 + xb4mbr = 0. +20 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48.and.ichar(durq).le.57) then + mbrest = 10*mbrest+ichar(durq)-48 + go to 20 + end if + else if (index('ul',durq) .gt. 0) then +c +c Set stem flipper +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'a') then +c +c "Alone", i.e., prohibit beam +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'r') then +c +c Right offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + go to 2 + else if (durq .eq. 'e') then +c +c Left offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 +c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to +c interbeams = internotes*2/3. +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c End stickyS. Grab data now from prior note, since we have to shut off stickyS. +c + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + stickyS = .false. + go to 2 + end if +c +c If durq .ne. ':' then iccount is now on the start of the number +c + call readnum(lineq,iccount,durq,dum) + call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2)) + if (durq .eq. ':') then + stickyS = .true. + else + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. ',') then +c +c 2:1 pattern +c + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. 'o') then +c +c Suppress rest centering +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25) + go to 2 + else if (durq .eq.'L') then +c +c With keyboard rest option, look left +c + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'A') then +c +c Accidental option +c + call getchar(lineq,iccount,durq) +c + if (durq .eq. 'o') then +c +c Ordered accidentals in a chord. Mark the main note. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28) + else +c +c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29) + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + print*,'Illegal character in note: ',durq,', ivx,nn:', + * ivx,nnl(ivx) + call stop1() + end if +c +c Done with note/rest options. Set level and duration. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + do 43 npreslur = npreslur , 1 , -1 +c +c Set level for preslur on normal note, non-chord +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +43 continue + end if + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (btest(islur(ivx,nnl(ivx)),19)) then +c +c Set duration of full-bar rest as pause +c + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + else if (ibarmbr.ne.nbars+1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + if (btest(islur(ivx,nnl(ivx)),3)) + * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + end if + if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then +c +c Shift is on, and this is not first shifted note. Check for duration change +c + if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then +c +c Must stop and restart the offset. +c + irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1) + end if + end if + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (autofbon .and. tautofb.gt.tol .and. fbon) then +c +c Check to see if need to terminate auto forced beam +c + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Terminate autofb +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + end if + end if + if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then +c +c Finished a bar +c + nbars = nbars+1 + nib(ivx,nbars) = nnl(ivx) + if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then +c +c Just finished the pickup bar for this voice. +c + lenbar = lenb1 + end if + end if + if (idotform .eq. 1) then + call getchar(lineq,iccount,charq) + idotform = 2 + numnum = 1 + go to 28 + else if (idotform .eq. 3) then + call getchar(lineq,iccount,charq) + idotform = 4 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then +c +c Chord note. Must have note name, may have octave#,+,-,s,f,n,d +c Actually the 'd' is not used, since time value comes from +c basic note. Unless dot is to be shifted! +c Doesn't increase # of notes, so must handle separately +c ncrd: index of crd +c Set bit 10 of ipl on main note as flag +c Bits in icrdat: +c 0-7 ip within voice +c 8-11 ivx +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Cautionary accidental +c +c Bits in icrdot: +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx) + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdot(ncrd) = 0 + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +25 call getchar(lineq,iccount,durq) +c ndx = index('fsn+-<>12345678rediA',durq) + ndx = index('fsn+-<>12345678rediAc',durq) + if (ndx .eq. 20) then +c +c Expect +|-|<|> , set tag, loop +c + icrdat(ncrd) = ibset(icrdat(ncrd),29) + go to 25 + else if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 21) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental on chord note +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else if (durq .eq. 'd') then +c +c Must keep 'd' optional (backward compatibility), unless it is moved! +c + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) + * .eq. 0) go to 25 + icrdat(ncrd) = ibset(icrdat(ncrd),26) + call getchar(lineq,iccount,durq) + iccount=iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '+') then + icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64) + else + icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64) + end if + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift specified also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '+') then + ifnum = nint(fnum*10)+64 + else + ifnum = -nint(fnum*10)+64 + end if + else + ifnum = 64 + end if + icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7)) + iccount = iccount-1 + end if + else +c +c must be a single digit, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 25 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 44 npreslur = npreslur , 1 , -1 + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Set level for chord note. +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0) + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0) + isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +44 continue + if (notcrd) then +c +c This is the first chord note in this chord. +c + minlev = min(nolev(ivx,nnl(ivx)),lastlev) + maxlev = max(nolev(ivx,nnl(ivx)),lastlev) + else + minlev = min(minlev,lastlev) + maxlev = max(maxlev,lastlev) + end if + notcrd = .false. + else if (charq .eq. 'G') then + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + continue +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c +c ngrace = ngrace+1 +c ivg(ngrace) = ivx +c ipg(ngrace) = nnl(ivx)+1 +c if (ngrace .eq. 1) then +c ngstrt(ngrace) = 1 +c else +c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) +c end if +c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) +c nng(ngrace) = 1 +c multg(ngrace) = 1 +c upg(ngrace) = .true. +c slurg(ngrace) = .false. +c slashg(ngrace) = .false. +c18 call getchar(lineq,iccount,charq) +c if (index('WA',charq) .gt. 0) then +cc +cc Grace is on note that was already done, so shift flags forward one note. +cc This puts flag on actual note with grace; later for W will go ahead one more. +cc +c ipg(ngrace) = nnl(ivx) +c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) +c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) +c if (slurg(ngrace)) +c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) +c if (charq .eq. 'A') then +cc +cc close After, clear way-after bit, to ensure priority of most recent A/W +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) +c else +cc +cc Way after; later assign to following note, and position like normal grace. +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) +c end if +c else if (charq .eq. 'm') then +c call getchar(lineq,iccount,charq) +c multg(ngrace) = ichar(charq)-48 +c else if (index('123456789',charq) .gt. 0) then +c call readnum(lineq,iccount,durq,fnum) +c iccount = iccount-1 +c nng(ngrace) = nint(fnum) +c else if (charq .eq. 'l') then +c upg(ngrace) = .false. +c else if (charq .eq. 's') then +c slurg(ngrace) = .true. +c if (nnl(ivx) .gt. 0) then +cc +cc If A- or W-grace, set signal to start slur on main note. +cc +c if(btest(ipl(ivx,nnl(ivx)),31) .or. +c * btest(ipl(ivx,nnl(ivx)),29)) +c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) +c end if +c else if (charq .eq. 'x') then +c slashg(ngrace) = .true. +c else if (charq .eq. 'u') then +c else if (charq .eq. 'X') then +cc +cc Space before main note of grace. Number will come next. +cc +c iccount = iccount+1 +c call readnum(lineq,iccount,durq,graspace(ngrace)) +c iccount = iccount-1 +c end if +c if (index('abcdefg',charq) .eq. 0) go to 18 +cc +cc At this point, charq is first note name in grace +cc +c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 +c naccg(ing) = 0 +c ioct = 0 +c if (ing .gt. ngstrt(ngrace)) then +c55 call getchar(lineq,iccount,charq) +c if (charq .eq. ' ') go to 55 +c endif +c iclastlev = 0 +c9 call getchar(lineq,iccount,durq) +c if (durq .ne. ' ') then +c if (durq.eq.'+') then +c lastlev = lastlev+7 +c iclastlev = iclastlev+7 +c else if (durq.eq.'-') then +c lastlev = lastlev-7 +c iclastlev = iclastlev-7 +c else if (index('fsn',durq) .gt. 0) then +c if (naccg(ing) .eq. 0) then +c naccg(ing) = index('fsn',durq) +c else +cc +cc Double accidental +cc +c naccg(ing) = ibset(naccg(ing),2) +c end if +c else +c ioct = ichar(durq)-48 +c end if +c go to 9 +c end if +c if (ioct .gt. 0) then +c lastlev = ifnolev(charq,ioct) +c else +c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c lastlev = ndlev(iv,kv)+iclastlev +c end if +c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) +c end if +c nolevg(ing) = lastlev +c19 continue +cc +cc Grace could come before first note of block, so reset end level. +cc +c if (nnl(ivx).eq.0) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c ndlev(iv,kv) = lastlev +c end if + else if (charq .eq. sq) then +c +c Literal TeX string +c + call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount) + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. Symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)), + * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx, + * .true.,notcrd,nole) + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx) + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detect preslur on normal non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') + * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx) + ArpShift(NumArpShift) = fnum + end if + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx), + * nodur(ivx,nnl(ivx)),figq(ivf,nfig1), + * ivupfig(ivf,nfig1),nfigs(ivf)) + else if (charq .eq. '[') then +c +c Start forced beam. Record barno & time since start of inp. blk. Set signal +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + nadj = 0 + if (autofbon) then + autofbon = .false. + end if +17 call getchar(lineq,iccount,charq) + if (index('ulf',charq) .gt. 0) then + ulfbq(ivx,nfb(ivx)) = charq + go to 17 + else if (charq .eq. 'j') then +c +c Continuing a jumped beam here +c + irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24) +c +c Set flag to watch for END of this forced beam, so can set flag rest(30) on +c NEXT note as signal to start a new notes group there. +c + isbj2 = .true. + go to 17 + else if (charq .eq. 'h') then + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2) + go to 17 + else if (charq .eq. 'm') then +c +c Force multiplicity. Next input is digit +c + call getchar(lineq,iccount,charq) + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) + call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48) + go to 17 + else if (charq .eq. ':') then +c +c Start auto forced beam pattern +c + autofbon = .true. +c +c When forced later beam ends, check whether tautofv <=0; if so set it. +c + tautofb = -itsofar(ivx) + t1autofb = itsofar(ivx) + go to 17 + else if (charq .ne. ' ') then +c +c Must be '+/-' for height or slope shift +c + nadj = nadj+1 +c +c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + iadj = nint(fnum) + if (charq .eq. '-') iadj = -iadj + if (nadj .eq. 1) then +c +c This is a level shift. Note if 0 was entered, iadj = 30 +c + call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30) + else if (nadj .eq. 2) then +c +c Must be a slope shift +c + call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30) + else +c +c Beam-thk fine tune +c + call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj) + end if + go to 17 + end if + else if (charq .eq. ']') then + if (autofbon .and. tautofb.lt.tol) then + tautofb=itsofar(ivx)+tautofb + end if + call getchar(lineq,iccount,charq) + if (index('j ',charq) .gt. 0) then +c +c Since ']' comes AFTER note, itsofar has been updated. Set ending signal. +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + if (charq .eq. 'j') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23) + if (isbj2) then +c +c This is the end of a fb segment of a jump beam. Set flag on NEXT note to +c force start of new notes group, provided this is not last note in bar. +c + if (mod(itsofar(ivx),lenbar) .ne. 0) + * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30) + isbj2 = .false. + end if + else if (charq .eq. '[') then +c +c Multiplicity down-up signal +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) + else if (charq .eq. '-') then +c +c Set signals for gap in single-slope beam [...]-[...] +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20) + nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21) +c +c Next two characters must be "[ ". Skip over them. +c + iccount = iccount+2 + end if + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)), + * iornq(ivx,nnl(ivx)),lineq,iccount) + else if (charq .eq. 'h') then +c +c Heading or height. For heading, only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "h" not at beginning of block' + call stop1() + end if + call getchar(lineq,iccount,durq) + ihdvrt = 0 + if (index('+-',durq) .gt. 0) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ihdvrt = fnum+.1 + if (durq .eq. '-') ihdvrt = -ihdvrt + durq = charq + end if + if (durq .ne. ' ') then +c +c Height symbol. Read past (until next blank) +c +3 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 3 + else +c +c Set flag for header & read it in +c + ihdht = 16 + call getbuf(headrq) + iccount = 128 + end if + else if (charq .eq. 'L') then +c +c Linebreak, already handled in pmxa, but check for movement break +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fmovbrk) + if (durq .eq. 'P') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + end if + if (durq .eq. 'M') then + movbrk = nint(fmovbrk) + movgap = 0 + parmov = -1. + call getchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Get vertical space (\internotes) +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + movgap = nint(fnum) + go to 31 + else if (durq .eq. 'i') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,parmov) + go to 31 + else if (durq .eq. 'c') then + nobar1 = .true. + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then +c +c "rename" can be set on or off. +c + call getchar(lineq,iccount,durq) + rename = durq.eq.'+' + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iiorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iiorig in original list of instruments. +c + nvold = nv + nv = 0 + rename = .true. + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')ninow + else + ninow = ichar(durq)-48 + end if + iiv = 0 + do 63 iinow = 1 , ninow + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow) + else + iiorig(iinow) = ichar(durq)-48 + end if + nspern(iinow) = nsperi(iiorig(iinow)) + nv = nv+nspern(iinow) + sepsymq(iiv+nspern(iinow)) = '&' + if (nspern(iinow) .gt. 1) then + do 64 iis = 1 , nspern(iinow)-1 + sepsymq(iiv+iis) = '|' +64 continue + end if + iiv = iiv+nspern(iinow) +63 continue + 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 (nv.eq.1 .and. nvold.gt.1) then + if (islast) write(11,'(a)')sq//'nostartrule' + else if (nv.gt.1 .and. nvold.eq.1) then + if (islast) write(11,'(a)')sq//'startrule' + end if + iiv = 0 + do 60 iinow = 1 , ninow + do 61 iis = 1 , nspern(iinow) + iiv = iiv+1 +c +c May not really need to re-enter clefs, but it's easier to program since +c clef names are not saved but are needed in newvoice to set ncmidcc. +c + call getchar(lineq,iccount,clefq(iiv)) + call newvoice(iiv,clefq(iiv),.true.) + if (nspern(iinow) .eq. 1) then + hdlndq = chax(48+numclef(clefq(iiv))) + lclf = 1 + else if (iis .eq. 1) then + hdlndq = '{'//chax(48+numclef(clefq(iiv))) + lclf = 2 + else if (iis .lt. nspern(iinow)) then + hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv))) + lclf = lclf+1 + else + hdlndq = + * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}' + lclf = lclf+2 + end if +61 continue +c +c setstaffs & setclef go by instrument, not voice +c + if (islast) then + if (iinow .lt. 10) then + write(11,'(a)')sq//'setstaffs' + * //chax(48+iinow)//chax(48+nspern(iinow))//'%' + write(11,'(a)')sq//'setclef'//chax(48+iinow) + * //hdlndq(1:lclf)//'%' + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinow, + * '}'//chax(48+nspern(iinow))//'%' + write(11,'(a9,i2,a)')sq//'setclef{',iinow, + * '}'//hdlndq(1:lclf)//'%' + end if + end if +60 continue +c +c Loop back up, this may not be last option in M. Note flow out if durq=' ' +c + call getchar(lineq,iccount,durq) + go to 31 + end if +c +c Write instrument names +c + if (.not.rename) then + do 62 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' + else + write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%' + end if + end if +62 continue + else + do 65 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst,'{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + end if + end if +65 continue + rename = .false. + end if + end if + else if (charq .eq.'|' ) then +c +c End of bar symbol. Check about end of bar hardspace. +c + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by a bar line. Remove it from the hardspace +c list, store with shifts instead, set special bit. Need to repeat this code +c at '/'. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + else if (index('wS',charq) .gt. 0) then +c +c Width symbol or new nsyst. Read past (until blank) +c +4 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 4 + else if (charq .eq. 'l') then +c +c Lower string. Only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "l" not at beginning of block' + call stop1() + end if +c +c Set flag for lower string & read it in +c + lower = .true. + call getbuf(lowerq) + iccount = 128 + else if (charq .eq. 'm') then +c +c Meter change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "m" not at beginning of block' + call stop1() + end if + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + call readmeter(lineq,iccount,mtrnmp,mtrdnp) + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenbar = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenbar = lenbar*2 + lenb1 = lenbar + lenb0 = 0 + if (ismidi) call midievent('m',mtrnuml,mtrdenl) + else if (charq .eq. 'C') then +c +c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. +c + if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 + tcc(iv,ncc(iv)) = itsofar(iv) + isl = ibset(islur(iv,nnl(iv)+1),11) + call getchar(lineq,iccount,durq) +c +c Store clef number, or 7 if clef number = 9 (French violin clef) +c + isl = ior(isl,ishft(min(numclef(durq),7),12)) + ncmidcc(iv,ncc(iv)) = ncmidf(durq) +c +c Set marker on note with lowest voice # starting at same time. +c + if (iv .eq. 1) then + isl = ibset(isl,15) + else + do 13 iiv = 1 , iv + nnliiv = nnl(iiv) + if (iiv .eq. iv) nnliiv = nnliiv+1 + itother = 0 + do 14 iip = 1 , nnliiv + if (itother .lt. itsofar(iv)) then + itother = itother+nodur(iiv,iip) + go to 14 + else if (itother .eq. itsofar(iv)) then + islur(iiv,iip) = ibset(islur(iiv,iip),15) + go to 15 + end if +14 continue +13 continue +15 continue + end if +c +c Need 'or' since may have set bit 15 in the above loop +c + islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) + else if (charq .eq. 'R') then +c +c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) +c +10 call getchar(lineq,iccount,durq) +c +c Save designator in case it's a terminal Rr or Rd +c + if (durq .eq. 'l') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5) + go to 10 + else if (index('rdDbz',durq) .gt. 0) then + if (durq .eq. 'r') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6) + else if (durq .eq. 'd') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8) + else if (durq .eq. 'D') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26) + else if (durq .eq. 'b') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25) + else if (durq .eq. 'z') then + iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) + end if + rptprev = .true. + rptfq1 = durq + go to 10 + end if + else if (charq .eq. 'V') then +c +c Ending +c + nnnl = nnl(1)+1 + lvoltxt = 0 +11 call getchar(lineq,iccount,durq) + if (durq.eq.'b' .or. durq .eq.'x') then +c +c End Volta, set bit9, and bit10 on if 'b' (end w/ box) +c + islur(1,nnnl) = ibset(islur(1,nnnl),9) + if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10) + go to 11 + else if (durq .ne. ' ') then +c +c Start volta; Get text +c + if (lvoltxt .eq. 0) then +c +c First character for text +c + lvoltxt = 1 + islur(1,nnnl) = ibset(islur(1,nnnl),7) + nvolt = nvolt+1 + voltxtq(nvolt) = durq + else + voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq + lvoltxt = lvoltxt+1 + end if + go to 11 + end if + else if (charq .eq. 'B') then + bcspec = .not.bcspec + else if (charq .eq. 'P') then +c +c Page numbers. Print stuff right now. +c + npg1 = 0 +c +c Will use ltopnam to signal whether there's a centered heading +c + ltopnam = 0 + ipg1r = 0 +16 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48 .and. ichar(durq).le.57) then + npg1 = npg1*10+ichar(durq)-48 + go to 16 + else if (durq .eq. 'l') then + if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1 + go to 16 + else if (durq .eq. 'r') then + if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1 + go to 16 + else if (durq .eq. 'c') then +c +c Top-centered name. Assume this is last option. Read the name. +c May surround name in double quotes (to allow blanks). +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + ltopnam = lenstr(cheadq,60) + else + namstrt = iccount + if (durq .eq. '"') then +c +c Using quote delimiters. +c + quoted = .true. + namstrt = namstrt+1 + else + quoted = .false. + end if + do 35 iccount = namstrt+1, 128 + if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. + * (.not.quoted .and. lineq(iccount:iccount) .eq. ' ')) + * go to 36 +c +c On exit, iccount is OK, and name is in (namstrt:iccount-1) +c +35 continue + print*,'Awww, cmon, should not be here.' + call stop1() +36 continue + ltopnam = iccount-namstrt + cheadq = lineq(namstrt:iccount-1) + end if + end if +c +c Done getting data, now assemble the command +c + if (npg1.eq.0) npg1=1 +c +c 2/23/03 Don't use \atnextline if on first page and only one system +c +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{' + lhead = 27 +c else +c hdlndq = sq//'toppageno{' +c lhead = 11 +c end if + if (npg1 .lt. 10) then +c +c Note we are overwriting the last "{" +c + write(hdlndq(lhead:lhead),'(i1)')npg1 + else if (npg1 .lt. 100) then + lhead = lhead+3 + write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}' + else + lhead = lhead+4 + write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}' + end if + hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{' + lhead = lhead+2 +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + 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 +c else +c if (ltopnam .eq. 0) then +c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' +c else +c if (islast) +c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' +c end if +c end if + else if (charq .eq. 'W') then +c +c Just eat the number that must follow, it was used in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else if (charq .eq. 'T') then + headlog = .true. + inhead = 0 + call getchar(lineq,iccount,durq) + if (durq .eq. 'i') then + call getbuf(instrq) +c +c A kluge for parts from separate score file for later movements. +c + if (instrq(1:1) .eq. ' ') headlog = .false. + cheadq = instrq + else if (durq .eq. 't') then + call getchar(lineq,iccount,durq) +c +c Optionally can include extra vertical \internotes above inbothd +c + if (index('-+0123456789',durq) .gt. 0) then + ipm = 1 + if (index('+-',durq) .gt. 0) then +c +c Don't trust readnum to round this negative integer properly +c + iccount = iccount+1 + if (durq .eq. '-') ipm = -1 + end if + call readnum(lineq,iccount,durq,fnum) + inhead = ipm*nint(fnum) + end if + call getbuf(titleq) + else + call getbuf(compoq) + end if + inhead = inhead+inbothd + iccount = 128 + else if (charq .eq. 'A') then +c +c Accidental handling etc. +c +27 call getchar(lineq,iccount,durq) + if (durq .eq. 'r') then + if (islast) then + relacc = .true. + write(11,'(a)')sq//'relativeaccid%' + end if + else if (durq .eq. 's') then + bacfac = 1.e6 + else if (durq .eq. 'b') then + if (islast) write(11,'(a)')sq//'bigaccid%' + accfac = bacfac + else if (durq .eq. 'a') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + else if (durq .eq. 'i') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,tintstf) + if (.not.firstgulp) fintstf = tintstf +c +c Local corrections for first page were handled by pmxa +c + iccount = iccount-1 + else if (durq .eq. 'I') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + else if (durq .eq. 'd') then + lowdot = .true. + else if (durq .eq. 'o') then + continue + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call getchar(lineq,iccount,durq) + if (index('-s',durq) .gt. 0) then + fullsize(iiv) = 0.8 + else if (durq .eq. 't') then + fullsize(iiv) = 0.64 + else + fullsize(ivx) = 1.0 + end if +50 continue + else if (durq .eq. 'e') then +c +c Line-spacing equalization +c + equalize = .true. +c +c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. +c But it causes problems with some older scores and when excerpts are combined +c with LaTeX. So as of 2.352 we write it here. +c + write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq + * //'Interligne minus 99'//sq//'Interligne%' + tempq = sepsymq(1) + lentemp = 1 + do 51 iiv = 2 , nv-1 + tempq = tempq(1:lentemp)//sepsymq(iiv) + lentemp = lentemp+1 +51 continue + write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes' + * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}' + * //sq//'en}%' + else if (durq .eq. 'v') then +c +c Toggle usevshrink +c + usevshrink = .not.usevshrink + else if (durq .eq.'p') then +c +c Postscript slurs. fontslur is already false (set in g1etnote) +c + if (.not.WrotePsslurDefaults) then +c +c Set postscrirpt slur adjustment defaults +c + write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust' + * //sq//'nohalfties' + WrotePsslurDefaults = .true. + end if +52 continue + call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l" + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c" + if (durq .eq. '+') then + if (charq .eq. 's') then + write(11,'(a)')sq//'Sluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Tieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'halfties' + else + SlurCurve = SlurCurve + 1 + if (SlurCurve .gt. 3.1) then + call printl('WARNING!') + call printl + * ('Default slur curvature advanced past HH, resetting') + SlurCurve = 3 + end if + end if + else + if (charq .eq. 's') then + write(11,'(a)')sq//'Nosluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Notieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'nohalfties' + else + SlurCurve = SlurCurve - 1 + if (SlurCurve .lt. -1.1) then + call printl('WARNING!') + call printl( + * 'Default slur curvature decremented below f, resetting') + SlurCurve = -1 + end if + end if + end if + go to 52 ! Check for another set of default changes + else if (durq .eq. 'l') then +c +c Set optional linebreak ties +c + OptLineBreakTies = .true. + go to 52 + else if (durq .eq. 'h') then +c +c Set flag to write header special on every page +c + HeaderSpecial = .true. + go to 52 + else + iccount = iccount-1 + end if + else if (durq .eq. 'K') then +c +c Toggle keyboard rest placement flag +c + kbdrests = .not.kbdrests + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) +c +c Just eat the input; it was used in pmax +c + go to 27 + end if + if (index('NR',durq) .gt. 0) then +c +c Override default part names for scor2prt, or normal include file. +c Just bypass rest of input line +c + iccount = 128 + else if (durq .ne. ' ') then + go to 27 + end if + else if (charq .eq. 'K') then + call getchar(lineq,iccount,durq) + if (durq .ne. 'i') then +c +c Normal, full-score key change and/or transposition +c + num1 = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = num1*nint(fnum) +c +c On exit, durq='+','-'. But only need isig if after start, else done in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (num1 .eq. 0) then +c +c Key change, not transposition. +c + ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28) + lastisig = isig + isig = nint(fnum) + if (durq .eq. '-') isig = -isig + isig = isig+idsig + if (ismidi) call midievent('k',isig,0) + else +c +c num1 .ne. 0, so transposition, so must be at beginning. isig came with K... +c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data +c (signature before transposition). idsig must be added to future key changes. +c + jv = 0 + do while (jv .lt. nm) + jv = jv+1 + iTransAmt(jv) = num1 + end do + idsig = isig-isig0 + end if + else +c +c Instrument specific transposition. + + call GetiTransInfo(.false.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '/') then + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by end of block. Remove it from the hardspace +c list, store with shifts instead, set special bit. This code also at '|' +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + call getchar(lineq,iccount,durq) +c +c Save ending note level: +c + if (ivx .le. nv) then +c +c This is the first line of music on this staff. If previous block had only 1 +c voice, save last pitch from line 1 of prev. block to line 2, in case a +c 2nd line is started just below +c + if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1) + was2(iv) = .false. + ndlev(iv,1) = lastlev + else +c +c This is the 2nd line of music on this staff. +c + was2(iv) = .true. + ndlev(iv,2) = lastlev + end if + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new line of music +c + if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0 + nbars = 0 + if (durq .eq. ' ') then +c +c New line of music is on next staff +c + iv = iv+1 + ivx = iv + else +c +c durq must be 2nd '/'. New line of music is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + nfb(ivx) = 0 + nudoff(ivx) = 0 + ndotmv(ivx) = 0 + do 24 j = 1 , 200 + irest(ivx,j) = 0 + islur(ivx,j) = 0 + nacc(ivx,j) = 0 + iornq(ivx,j) = 0 + ipl(ivx,j) = 0 + mult(ivx,j) = 0 +24 continue +c +c Go back and lower the rests in voice "a" that don't have over-ridden heights +c + do 26 j = 1 , nnl(iv) + if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0) + * nolev(iv,j) = -4 +26 continue + end if + end if + iccount = 128 + else if (charq .eq. 'X') then +c +c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, +c which only happens for normal X at block start, and we took special measures to +c keep group shifts for crossing block boundaries. +c + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))), + * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx, + * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub) + else if (charq .eq. 'I') then +c +c Midi controls. +c + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.false.) + else if (charq .eq. 'M') then +c +c Macro action +c + call getchar(lineq,iccount,charq) + if (index('RS',charq) .gt. 0) then +c +c Record or save a macro. Get the number of the macro. +c + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call mrec1(lineq,iccount,ndxm) + else +c +c Save (Record but don't activate) +c +5 call mrec1(lineq,iccount,ndxm) + if (mrecord) then + call getbuf(lineq) + iccount = 0 + go to 5 + end if + iccount = iccount+ndxm+1 + end if + else if (charq .eq. 'P') then +c +c Playback the macro +c + call getchar(lineq,iccount,charq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + icchold = iccount + lnholdq = lineq + iccount = 128 + ilmac = il1mac(macnum) + mplay = .true. + end if + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Check for start of forced beam on 2nd member of dotform=1 shortcut +c + if (fbon) then + if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx)) + * t1fb(ivx,nfb(ivx)) = + * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2 + end if +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + end if + return + end + subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg, + * ip,ivx,noxtup,notcrd,nole) +c +c iornq: Main note. Do not alter if chord note, except turn on bit 23 +c iornq0: Store iorni + bit 23, in case of repeated ornaments +c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. +c noffseg: horiz. offset for segno +c nole: level of note w/ orn, used to ID the note/orn if there's a level shift. +c + + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comcb/ nbc,ibcdata(36) + character*1 charq,durq + character*128 lineq + logical ornrpt,negseg,noxtup,notcrd +c +c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U +c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD +c + call getchar(lineq,iccount,charq) + if (index('bc',charq) .gt. 0) then +c +c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) +c ivx(0-3,28), ip(4-12), +c vshift (vshift+32 in bits 13-18), +c hshift (nint(10*vshift)+128 in bits 19-26) +c bit 27 = 0 if caesura, 1 if breath +c bit 28: 5th bit of ivx +c + iornq = ibset(iornq,28) + nbc = nbc+1 +c ibcdata(nbc) = ivx+16*ip + ibcdata(nbc) = mod(ivx,16)+16*ip + if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28) + if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27) + call getchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c We have a vertical shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),6,13,nint(32+fnum)) + if (index('+-',charq) .gt. 0) then +c +c Horizontal shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128) + end if + end if + return + end if +c +c Set signal on main note that some note at this time has ornament. ONLY used +c in beamstrt to activate further tests for whether ihornb is needed. +c + iornq = ibset(iornq,23) +c +c Isolate 21 bits defining exisiting ornaments +c + if (notcrd) then + iorni = iand(4194303,iornq) + else + iorni = iand(4194303,icrdorn(ncrd)) + end if + korn = index('stmgx+Tupf._)e:XXX>^',charq) + if (korn .ne. 15) iorni = ibset(iorni,korn) +c +c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later +c as follows: korn=16-18 for sfn, and or 21 for bare ?. +c When this if-block is done, korn will = bit# of actual ornament (unless "?"). +c + if (korn .eq. 15) then +c +cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq +c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq +c +c iorni = ior(iorni,iand(iornq0,1638383)) + iorni = ior(iorni,iand(iornq0,3735535)) + ornrpt = .false. + call getchar(lineq,iccount,durq) +c +c durq will be ' ' +c + else if (korn .eq. 14) then +c +c Editorial accidental +c + call getchar(lineq,iccount,durq) +c korn = 15+index('sfn',durq) + korn = 15+index('sfn?',durq) + if (korn .eq. 19) korn=21 + iorni = ibset(ibclr(iorni,14),korn) + call getchar(lineq,iccount,durq) + if (durq .eq. '?') then +c +c This is "oe[s|f|n]?". Set 21st bit also. +c + iorni = ibset(iorni,21) + korn = korn+6 + call getchar(lineq,iccount,durq) + end if +c iorni = ibset(ibclr(iorni,14),korn) + else if (korn.eq.4 .and. noxtup) then +c +c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points +c + noffseg = 0 + negseg = .false. + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Segno shift is specified +c + if (durq .eq. '-') then + negseg = .true. + call getchar(lineq,iccount,durq) + end if + call readnum(lineq,iccount,durq,fnum) + noffseg = int(fnum) + if (negseg) noffseg = -noffseg + end if + else if (korn .eq. 7) then +c +c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = ip + xnsktr(ntrill) = 1. + call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Convert to new internal symbol for non-'"tr" trill +c + korn = 15 + iorni = ibset(ibclr(iorni,7),15) + call getchar(lineq,iccount,durq) + end if + if (index('0123456789.',durq) .gt. 0) then +c +c We have a number for the length +c + call readnum(lineq,iccount,durq,xnsktr(ntrill)) + end if + else if (korn.eq.10 .and. noxtup) then +c +c Fermata +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'd') then + korn = 14 + iorni = ibset(ibclr(iorni,10),14) + call getchar(lineq,iccount,durq) + end if + else + call getchar(lineq,iccount,durq) + end if + if (index('+- :',durq) .eq. 0) then + print*,'Unexpected character at end of ornament: ',durq + call stop1() + end if + if (index('+-',durq) .gt. 0) then +c +c Shift ornament up or down +c + nudorn = nudorn+1 +c +c Set bit 25 in iorni as a signal. This may not really be necessary. +c + iorni = ibset(iorni,25) +c +c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, +c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present +c + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iofforn = nint(xofforn*fnum) + kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12) + * +ishft(korn,19)+ishft(iofforn+32,25) + ivxudorn(nudorn) = ivx + if (index('+-',durq) .gt. 0) then +c +c Horizontal shift +c + kudorn(nudorn) = ibset(kudorn(nudorn),31) + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ornhshft(nudorn) = nint(xofforn*fnum) + end if + else if (durq .eq. ':') then +c +c Turn on repeated ornaments +c + ornrpt = .true. +c +c Save the ornament value just set +c + iornq0 = iorni + end if + if (notcrd) then + iornq = ior(iornq,iorni) + else + icrdorn(ncrd) = ior(icrdorn(ncrd),iorni) + end if + return + end + subroutine getpmxmod(global,includeq) +c +c If global=.true., checks for environment variable with path to pmx.mod. +c Then, if variable exists and points to pmx.mod, insert lines from +c pmx.mod into buffer +c If global=.false., checks for existence of includeq and uses it. +c +c lenbuf0 = total length of bufq on entry +c lbuf(i) = length of line (i) +c nlbuf = number of lines stored in bufq +c ilbuf = index of first line after setup stuff (on entry). In general, index of +c next line to be sucked from buffer. +c ilbufmod = counter for lines in pmx.mod as they are grabbed. +c Starts at ilbuf. Points to position of next line after +c pmx.mod stuff in bufq on exiting loop 1 +c ilbuff = transient counter for shifting operations +c ipbuf = on entry, points to last character in setup stuff. In general, points +c to last character of most recent line sucked from buffer. +c ipbufmod = points to last character of most recent inserted line +c from pmx.mod +c + parameter (maxblks=4000,nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,fbon,issegno,isheadr,isvolt + character*(*)includeq + character*80 pmxmoddirq + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical fexist,global + line1pmxmod = ilbuf + if (.not.global) then + inquire(file=includeq,EXIST=fexist) +c +c Transfer includeq to temporary char variable with known length +c + pmxmoddirq = includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + print* + write(15,'()') + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', checking further.') +c +c File named includeq doesn't not exist. Get directory from PMXMODDIR and +c see if it's there +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq. gt. 0) then + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + else + call printl( + * 'No other directory defined by PMXMODDIR, stopping') + call stop1() + end if + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', stopping.') + call stop1() + end if + end if + call printl('Opening normal include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq) + else +c +c Check for existence of pmx.mod +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq .eq. 0) return + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod' + lpmxmoddirq = lpmxmoddirq+7 + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) return + call printl('Opening global include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq(1:lpmxmoddirq)) + end if + call printl('Adding include data') +c +c Read lines in from pmx.mod one at a time +c + ipbufmod = ipbuf + lenbufmod = lenbuf0 + do 1 ilbufmod = ilbuf , maxblks + read(18,'(a)',end=3)lnholdq +c +c A line was read. Slide all existing lengths from here forward ahead by 1 +c + do 2 ilbuff = nlbuf , ilbufmod , -1 + lbuf(ilbuff+1) = lbuf(ilbuff) +2 continue +c +c Get length of line from include file +c + lenmodline = lenstr(lnholdq,128) + if (lenmodline .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lenmodline = 1 + lnholdq = ' ' + end if + lbuf(ilbufmod) = lenmodline + call printl(lnholdq(1:lenmodline)) +c +c Insert new stuff into bufq +c + bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)// + * bufq(ipbufmod+1:lenbufmod) +c +c Update internal parameters +c + ipbufmod = ipbufmod+lbuf(ilbufmod) + lenbufmod = lenbufmod+lbuf(ilbufmod) + nlbuf = nlbuf+1 +1 continue +3 continue + call printl('Closing '//pmxmoddirq(1:lpmxmoddirq)) + close(18) + linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf + lenbuf0 = lenbufmod +c +c Fix Andre's error reporting problem 101211 leading to log(neg#) due +c to nline being 2 bigger than it should be +c + nline=nline-2 +c + return + end + subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0, + * inameq,clefq,sepsymq,pathnameq,lpath,isig0) + parameter (nm=24) + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*1 clefq(nm),sepsymq(nm) + character*40 pathnameq + character*79 inameq(nm) + character*128 lineq + logical istype0,newway,rename +c +c Get the first line +c + iccount = 0 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 9 + istype0 = lineq(1:3).eq.'---' + if (istype0) then +c +c Have TeX input until next line that starts with '---'. Save in scratch. +c + open(17,status='SCRATCH') +3 call getbuf(lineq) + if (lineq(1:3) .ne. '---') then + write(17,'(a)')lineq + go to 3 + end if +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq is first line w/ numerical setup data. +c + nv = nint(readin(lineq,iccount,nline)) + noinst = nint(readin(lineq,iccount,nline)) + newway = noinst.le.0 + if (newway) noinst = -noinst + do 2 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then +c +c Read in nvi for each instrument +c + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if + iiorig(iinst) = iinst + nspern(iinst) = nsperi(iinst) +2 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge to make mtrdenl work +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + xmtrnum0 = readin(lineq,iccount,nline) +c +c Original key sig (before any trnasposition) in next position. Transposed +c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key +c changes if transposed. +c + isig0 = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musicsize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , noinst +5 call getbuf(inameq(i)) + if (inameq(i)(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 6 + iv = 0 + nvsofar = 0 + do 1 jinst = 1 , noinst + nvsofar = nvsofar+nsperi(jinst) + do 10 ivi = 1 , nsperi(jinst) + iv = iv+1 + clefq(iv) = lineq(iv:iv) + if (iv .eq. nvsofar) then + sepsymq(iv) = '&' + else + sepsymq(iv) = '|' + end if +10 continue +1 continue +c +c Mext non-comment line has path name +c +8 call getbuf(pathnameq) + if (pathnameq(1:1) .eq. '%') go to 8 + lpath = index(pathnameq,' ')-1 + return + end + function getsquez(n,ntot,space,tnote,to) + real*4 tnote(600),to(600) + common /comtol/ tol +c +c Get the squez factor by checking space against tgovern=minimum duration +c of all notes sounding at time of n-th note in the list. +c The starting time of base increment is to(n) and ending time is to(n)+space +c Sounding notes are those that start at or before to(n) .and. end at or +c after tend=to(n)+space +c Since notes are ordered by increasing start times, as soon as we find one +c that starts too late, we are done checking. +c + tgovern = 1000. + tend = to(n)+space + do 1 in = 1 , ntot +c +c Since to() is ordered by start times, exit loop after first note that +c starts later than note of interest. +c + + if (to(in) .gt. to(n)+tol) go to 2 + if (to(in)+tnote(in) .gt. tend-tol) then +c +c If here, this note overlaps and must be tested. +c + tgovern = min(tgovern,tnote(in)) + end if +1 continue +2 continue + getsquez = space/tgovern + return + end + subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx, + * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub) + parameter(nm=24) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c Since during getnote phase time is integer itsofar, which is not updated +c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if +c not in xtup. +c + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical shifton,colon,ess,number + character*128 lineq + character*1 charq,durq,dotq + colon = .false. + ess = .false. + number = .false. + nextbl = iccount+index(lineq(iccount:128),' ')-1 + if (index(lineq(iccount:nextbl),'P') .gt. 0) then +c +c "Parts only", ignore entire symbol +c + iccount = nextbl + return + end if +1 call getchar(lineq,iccount,charq) + if (charq.eq.'B') then +c +c "Both parts and score," ignore character +c + go to 1 + else if (charq .eq. ':') then + colon = .true. + go to 1 + else if (charq .eq. 'S') then + ess = .true. + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (charq.eq.'-') iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum = -fnum + if (durq .ne. 'p') then + fnum = fnum*wheadpt + iccount = iccount-1 + end if + go to 1 + end if +c +c charq must be blank, so done parsing +c + if (.not.ess .and. .not.colon) then +c +c Ordinary hardspace. Goes before next note. +c (Later, at "|" or "/", check for presence and switch to udoff if there!) +c + nudsp = nudsp+1 + iornq1 = ibset(iornq1,26) + udsp(nudsp) = fnum + tudsp(nudsp) = itsofar + if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp) +c * +float(itup-1)/ntup*ifnodur(nnodur,dotq) + * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq) + else if (.not.number) then +c +c Must be "X:" End a group offset. +c + irest = ibset(irest,17) + shifton = .false. + return + else +c +c Only other possibility is start offset, "S" for single, ':' for multiple +c + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = fnum + if (ess) then + irest1 = ibset(irest1,15) + else + irest1 = ibset(irest1,16) + shifton = .true. + end if + end if + return + end + function i1fnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + i1fnodur=1 + else if (idur .eq. 3) then + i1fnodur=2 + else if (idur .eq. 1) then + i1fnodur=4 + else if (idur .eq. 8) then + i1fnodur=8 + else if (idur .eq. 4) then + i1fnodur=16 + else if (idur .eq. 2) then + i1fnodur=32 + else if (idur .eq. 0) then + i1fnodur=64 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + i1fnodur=4 + else if (idur .eq. 9) then + i1fnodur = 128 + else + print* + print*,'You entered an invalid note-length value:',idur + call stop1() + end if + if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2 + return + end +c integer*4 function longi(ishort) +c integer*2 ishort +c longi = ishort +c return +c end + function iashft(nacc) + integer*4 ias(6) + data ias /-1,1,0,0,-2,2/ + iashft = ias(nacc) + return + end + function ifnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + ifnodur=1 + else if (idur .eq. 3)then + ifnodur=2 + else if(idur .eq. 1) then + ifnodur=4 + else if(idur .eq. 8) then + ifnodur=8 + else if(idur .eq. 4) then + ifnodur=16 + else if(idur .eq. 2) then + ifnodur=32 + else if(idur .eq. 0) then + ifnodur=64 + else if(idur .eq. 9) then + ifnodur=128 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + ifnodur=4 + else + print*,'You entered an invalid note value' + stop + end if + if (dotq .eq. 'd') ifnodur = ifnodur*3/2 + return + end + function ifnolev(noq,oct,ntrans) + character*1 noq + integer oct + ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans + return + end +c subroutine report(nsdat,isdat1,isdat2) +c integer*4 isdat1(202),isdat2(202) +c write(*,'(a)') +c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' +c do 1 isdat = 1 , nsdat +c isdata = isdat1(isdat) +c ionoff = igetbits(isdata,1,11) +cc iv = iand(7,isdata) +c iv = igetbits(isdata,5,13) +c kv = igetbits(isdata,1,12)+1 +c ip = igetbits(isdata,8,3) +c idcode = igetbits(isdata,7,19) +c iud1 = igetbits(isdata,1,26) +c iud2 = igetbits(isdata,1,27) +c ndxslur = igetbits(isdata,4,28) +c isdatb = isdat2(isdat) +c ivo = igetbits(isdatb,6,6)-32 +c iho = igetbits(isdatb,7,12)-64 +c lev = igetbits(isdatb,7,19) +c icrd = igetbits(isdatb,1,0) +c lhd = igetbits(isdatb,1,1) +c irhd = igetbits(isdatb,7,2) +c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, +c * ivo,iho,lev,icrd,lhd,irhd +c1 continue +c print* +c return +c end + function igetbits(isdata,iwidbit,ishift) +c +c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and +c then added to ioff +c + igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift)) + return + end + function igetvarlen(mmidi,icm,imidi,nbytes) +c +c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. +c + parameter (nm=24,mv=24576) + integer*2 mmidi(0:nm,mv) + igetvarlen = 0 + do 1 nbytes = 1 , 4 + igetvarlen = 128*igetvarlen + * +iand(127,mmidi(icm,imidi+nbytes)) +c * +iand(127,longi(mmidi(icm,imidi+nbytes))) + if (.not.btest(mmidi(icm,imidi+nbytes),7)) return +c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return +1 continue + print*,'Messup in igetvarlen' + call stop1() + end + logical function isdotted(nodur,ivx,ip) + parameter (nm=24) +c +c Function returns true if note is dotted or double-dotted. +c Return false for any xtuplet. +c + common /comtol/ tol + integer*4 nodur(nm,200) + if (nodur(ivx,ip) .eq. 0) then + isdotted = .false. + return + else if (ip .gt. 1) then + if (nodur(ivx,ip-1) .eq. 0) then + isdotted = .false. + return + end if + end if +c +c Ruled out all xtups, so is dotted or double-dotted if not a power of 2. +c + isdotted = + * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol + return + end + function isetvarlen(idur,nbytes) + isetvarlen = 0 + itemp = idur + do 1 nbytes = 1 , 4 + isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1) + itemp = ishft(itemp,-7) + if (itemp .gt. 0) then + isetvarlen = isetvarlen+2**(8*nbytes+7) + else + return + end if +1 continue + print*,'Problem in function isetvarlen' + call stop1() + end + subroutine istring(i,string,len) +c +c Returns string with integer only if length is 1, otherwise enclosed in +c brackets. +c + character*(*) string + if (i .ne. 0) then + len = alog10(abs(i)*1.0001)+1 + if (i .lt. 0) len = len+1 + else + string = '0' + len = 1 + return + end if + if (len .eq. 1) then + string = char(48+i) + else + string = '{' + write(string(2:1+len),'(i'//char(48+len)//')')i + string = string(1:len+1)//'}' + len = len+2 + end if + return + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + function levrn(nolev,irest,iud,ncm,mult) +c +c Used for placing numbers in xtups. Returns note level if not a rest, +c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. +c + logical btest + if (.not.btest(irest,0)) then + levrn = nolev + else +c +c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. +c + if (mult .gt. 0) then + if (mult .eq. 2) then + ioff = -1+2*iud + else if (mult .ne. 4) then + ioff = iud*mult + else + ioff = 1+4*iud + end if + else +c +c May need to futz with this later for non-beamed xtups (quarter, half rests) +c + ioff = iud*2 + end if + levrn = mod(nolev+20,100)-20+ncm+ioff + endif + return + end + function lfmt1(x) +c +c Computes total length of an "f" format with one decimal place. +c First round to nearest 0.1 +c + if (abs(x) .lt. .001) then + lfmt1 = 2 + else + y = sign(.1*int(10*abs(x)+.5),x) + lfmt1 = int(log10(1000*abs(y)+.001)) + if (y .lt. 0) lfmt1 = lfmt1+1 + end if + return + end + subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + parameter (nm=24) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie + character*1 udq,chax,sepsymq(nm) + character*8 noteq + character*128 notexq +c +c This is called twice from pmxb after having input an entire block, before +c making a bar that starts a new system. So nsdat reflects all slur starts +c and stops in new block, while listslur, which is only set when bars are +c made, reflects only open slurs from the old block. So we must check +c listslur to find open ties, not all nsdat. +c First of two calls (ispstie=.false. on entry) terminates tie at end of line. +c Second (ispstie=.true. on entry) restarts tie at start of new line. Only +c need data from original tie-start for both of these. Tie/slur data from +c closing of full tie are not used except for shape alterations. +c +c do 1 ndx = 0 , 11 + do 1 ndx = 0 , 23 + if (btest(listslur,ndx)) then +c +c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie +c + do 2 isdat = 1 , nsdat +c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index + if (igetbits(isdat1(isdat),4,28) + * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index + if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop + if (btest(isdat2(isdat),3)) go to 3 ! "st" + idcode = igetbits(isdat1(isdat),7,19) + if (idcode.eq.1) go to 3 ! "t" + tie = .false. + go to 5 +2 continue + end if + go to 1 +3 continue + tie = .true. +5 continue +c +c A slur or tie is open, with index ndx +c + iv = igetbits(isdat1(isdat),5,13) + kv = igetbits(isdat1(isdat),1,12)+1 + udq = 'd' + if (btest(isdat1(isdat),27)) udq='u' + notexq = chax(92)//'znotes' + lnote = 7 + do 4 iiv = 1 , iv-1 + notexq = notexq(1:lnote)//sepsymq(iiv) + lnote = lnote+1 +4 continue + if (kv .eq. 2) then + notexq = notexq(1:lnote)//chax(92)//'nextvoice' + lnote = lnote+10 + end if +c +c Compute horiz and vert offsets +c +c nolev = igetbits(isdat2(isdat),7,19) + islhgt = igetbits(isdat3(isdat),8,14) + ilb12 = 0 + if (ispstie) ilb12 = 1 + ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32 + if (ivoff .eq. -32) ivoff = 0 +C nolev = nolev+ivoff + islhgt = islhgt+ivoff + ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff + if (ihoff .eq. -64) ihoff = 0 +c +c Add starting stuff for command +c + if (.not.ispstie) then ! End 1st segment + notexq = notexq(1:lnote)//chax(92)//'roffset{' + lnote = lnote+9 +c hoff = ihoff*.1-.5 +c hoff = ihoff*.1-.8 + hoff = ihoff*.1-.4 + if (hoff .lt. 0) then + hoff = -hoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(hoff,notexq,lnote) + notexq = notexq(1:lnote)//'}{' + lnote = lnote+2 + else + notexq = notexq(1:lnote)//chax(92)//'off{-' + * //chax(92)//'afterruleskip}' + lnote = lnote+21 +c +c 091025 add dotting for 2nd segment if needed +c + if (btest(isdat2(isdat),4)) then + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if + end if + if (ispstie .and. tie) then + notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq + lnote = lnote+10 + end if + if (btest(isdat3(isdat),0)) then +c +c Curvature tweak on termination of 1st seg +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: +c Abs(imid) Postscript slur type +c 1 f +c 4 h +c 5 H +c 6 HH +c + notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid) + lnote = lnote+9 +c +c Zero out the flag in case there's a different curv on term of 2nd, +c + isdat3(isdat) = ibclr(isdat3(isdat),0) + end if +c +c Add the command name +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'is'//udq + lnote = lnote+4 + else if (tie) then + notexq = notexq(1:lnote)//chax(92)//'ttie' + lnote = lnote+5 + else + notexq = notexq(1:lnote)//chax(92)//'tslur' + lnote = lnote+6 + end if +c +c Add index +c +c if (11-ndx .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndx) +c lnote = lnote+1 +c else +c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' +c lnote = lnote+4 +c end if + if (23-ndx .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndx) + lnote = lnote+1 + else if (23-ndx .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}' + lnote = lnote+4 + end if + if (ispstie .or. .not.tie) then +c +c Add note name for slur height +c + noctup = 0 + ncm = igetbits(isdat3(isdat),8,22) + if (ncm .eq. 23) noctup = -2 +c call notefq(noteq,lnoten,nolev,ncm) + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}' + lnote = lnote+1+lnoten+1 + end if + if (ispstie) then +c +c Horizontal shift start of new thing +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 +c ihoff = ihoff-13 + if (tie) then + ihoff = ihoff-12 + else + ihoff = ihoff-7 + end if + if (ihoff .lt. 0) then + ihoff = -ihoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(ihoff*.1,notexq,lnote) + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Add closing stuff +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'off{' + * //chax(92)//'afterruleskip}' + lnote = lnote+20 + else + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//chax(92)//'en%' + lnote = lnote+4 + write(11,'(a)')notexq(1:lnote) +1 continue + ispstie = .not.ispstie + return + end + subroutine littex(islur,nnl,iv,topmods,lineq,iccount) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + integer islur(nm,200) + logical topmods + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,merge + character*128 lineq,litq + character*20 voltxtq + character*1 durq,chax + merge = .false. + if (nlit .gt. 0) then + merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit) + end if + nlit = nlit+1 + ivlit(nlit) = iv + iplit(nlit) = nnl + itype = 1 +17 call getchar(lineq,iccount,durq) + if (durq .eq. chax(92)) then + itype=itype+1 + go to 17 + end if + litq(nlit) = chax(92)//durq + lenlit(nlit) = 2 +18 call getchar(lineq,iccount,durq) + if (durq.eq.chax(92)) then + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Starting a new tex command within the string +c + litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq + lenlit(nlit) = lenlit(nlit)+2 + go to 18 + end if + else + litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq + lenlit(nlit) = lenlit(nlit)+1 + go to 18 + end if +c +c If here, just read backslash-blank so string is done +c + if (itype .eq. 1) then + islur(iv,nnl) = ibset(islur(iv,nnl),16) + if (merge) then +c +c There are 2 separate strings on the same note, so merge them. +c + nlit = nlit-1 + litq(nlit) = litq(nlit)(1:lenlit(nlit)) + * //litq(nlit+1)(1:lenlit(nlit+1)) + lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1) + if (lenlit(nlit) .gt. 128) then + print* + print*, + * 'Merged type-1 TeX strings longer than 128 characters' + write(15,'(/,a)') + * 'Merged type-1 TeX strings longer than 128 characters' + call stop1() + end if + end if + else + if (itype .eq. 3) then +c +c Write the string NOW +c + if (islast) + * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + else +c +c Must go at top +c + if (.not.topmods) then + topmods = .true. + open(16,status='SCRATCH') + end if +c +c Must write '%' here rather than later, in case string ends with blank. +c + write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + end if + nlit = nlit-1 + end if + return + end + function llen(strq,n) + character*129 strq + do 1 llen = n , 0 , -1 + if (strq(llen:llen) .ne. ' ') return +1 continue + end + function log2(n) +c +c 5/25/08 Modify to allow more slurs +c +c log2 = alog(1.*n)/0.6931472+.0001 +c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 + log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0 + return + end + subroutine logbeam(numnew,nip1,nip2) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq,ulfq,ulfbq + logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest, + * autofbon + ibm1(ivx,numnew) = nip1 + ibm2(ivx,numnew) = nip2 + numnow = numnew + if (numnew .gt. 1) then +c +c If it starts before any others, must put it in order +c + do 11 ib = numnew-1 , 1 , -1 + if (ibm1(ivx,ib) .lt. nip1) go to 12 + ibm1(ivx,ib+1) = ibm1(ivx,ib) + ibm2(ivx,ib+1) = ibm2(ivx,ib) + ulq(ivx,ib+1) = ulq(ivx,ib) + ibm1(ivx,ib) = nip1 + ibm2(ivx,ib) = nip2 + numnow = ib +11 continue +12 continue + end if + sum = 0. +c +c Beam has non-xtup within +c + nrests = 0 + isxtup = .false. + do 9 iip = nip1 , nip2 + if (btest(islur(ivx,nip1),21)) then +c +c Forced multiplicity +c +c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) + call setbits(mult(ivx,iip),4,0, + * igetbits(islur(ivx,nip1),3,22)+8) + else if (.not.isxtup) then + if (nodur(ivx,iip) .gt. 0) then +c mult(ivx,iip) = 4-log2(nodur(ivx,iip)) + call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8) + else +c +c Start xtup within forced beam +c + isxtup = .true. + iip1 = iip + end if + else if (isxtup .and. nodur(ivx,iip).gt.0) then +c +c End of xtup within forced beam. Must count doubled notes +c + ndoub = 0 + do 1 iiip = iip1 , iip + if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1 +1 continue + multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)- + * alog(nodur(ivx,iip)/2.))/0.69315)-10 + do 74 iiip = iip1 , iip +c mult(ivx,iiip) = multx + call setbits(mult(ivx,iiip),4,0,multx+8) +c +c Note the following still works after making mult only the 1st 4 bits. +c + if (btest(nacc(ivx,iiip),18)) + * mult(ivx,iiip) = mult(ivx,iiip)-1 + if (btest(nacc(ivx,iiip),19)) then + mult(ivx,iiip) = mult(ivx,iiip)+1 + else if (iiip .gt. 1) then + if (btest(nacc(ivx,iiip-1),19)) + * mult(ivx,iiip) = mult(ivx,iiip)+1 + end if +74 continue + isxtup = .false. + end if + if (btest(irest(ivx,iip),0)) then + nrests = nrests+1 + else + sum = sum+nolev(ivx,iip) + end if +9 continue +c +c Set beam up-down-ness +c + if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then + if (ulfbq(ivx,ifb) .eq. 'f') then +c +c Get default, then trade "l" and "u" +c + ulq(ivx,numnow) = char(225-ichar( + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)))) + else + ulq(ivx,ifb) = ulfbq(ivx,ifb) + end if +c +c This probably works only because forced beams are done first, so they +c don't have to be re-sorted within each voice. ???? +c + else if (nvmx(iv) .eq. 2) then +c +c Multi-voice per staff +c + if (ivx .le. nv) then + ulq(ivx,numnow) = 'l' + else + ulq(ivx,numnow) = 'u' + end if + else +c +c Defaults +c + ulq(ivx,numnow) = + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)) + end if + return + end + subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + logical mrecord,mplay,endmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lbuf(1) = lbuf(1) + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then + call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1, + * 'Improper macro termination!') + call stop1() + end if + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + parameter (nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst + common /comeskz2/ eskz2(nm,200) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm), + * numbms(nm),mapfb(16) + real*4 xit(nm),t1xtup(20),tstart(80),squez(80) + character*1 ulfbq + character*79 inameq + character*20 voltxtq + common /comoct/ noctup + character*80 headrq,lowerq + logical cwrferm + common /comcwrf/ cwrferm(nm) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical lower,cwrest(nm),vxtup,flgndb,btest,upslur, + * infbmx(nm),lowdot,inxtup(nm),drawbm + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Above are factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur, + * WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comntot/ ntot + if (ismidi) then +c +c Initialize for this bar the accidental counter for the midi file. +c naccim(icm) = # of accidentals from earlier in the bar +c + do 45 iv = 1 , nv + do 45 kv = 1 , nvmx(iv) + naccim(midchan(iv,kv)) = 0 +45 continue + end if +c +c Time from start of gulp to end of bar, used with forced beams +c + tglp2 = lenb0+ibar*lenb1 + if (lenb0 .gt. 0) tglp2 = tglp2-lenb1 + tglp1 = tglp2-lenbar +c +c infbmx will only be true if in xtup that is NOT in explicit forced beam. +c + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrest(ivx) = .false. + infbmx(ivx) = .false. + inxtup(ivx) = .false. + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv). The loop to 4 +c ONLY initializes each voice. +c + in = 1 + nxtup = 0 + narp = 0 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrferm(ivx) = .false. + cnn(ivx) = 1 + ivxo(in) = ivx + ipo(in) = cnn(ivx) + tnote(in) = fnote(nodur,ivx,1,nacc) + to(in) = 0. + xit(ivx) = tnote(in) +c +c Note that xit(ivx) is to END of note in voice, but it1xtup is start time. +c + if (nodur(ivx,ipo(in)) .eq. 0) then +c +c First note of xtuplet at start of bar in voice ivx. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = 0. +c +c Xtup at start of bar. If no explicit forced beam, start one, set +c signal infbmx, and save number ifbnow for use at termination. +c + if (nfb(ivx) .gt. 0) then + do 60 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c No explicit fb here; so exit loop and insert one. +c + go to 61 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit fb here; must NOT insert one +c + go to 62 + end if +60 continue + end if +61 continue +c +c If here, xtup isn't in explicit fb, so must insert one +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+ + * tglp1,t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +62 continue + if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000. + in = in+1 +4 continue +c +c Build the list: This is a manual loop starting at 5 +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iiv = 1 , nv + do 6 kv = 1 , nvmx(iiv) + iivx = ivmx(iiv,kv) + tminn = min(tmin,xit(iivx)) + if(tminn .lt. tmin-tol) then + tmin = tminn + ivx = iivx + end if +6 continue + if (abs(tmin-1000.) .lt. tol) go to 7 + ivxo(in) = ivx + cnn(ivx) = cnn(ivx)+1 + ipo(in) = cnn(ivx) + to(in) = tmin +c +c Check if this voice is done +c + tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc) + if (cnn(ivx) .eq. nn(ivx)) then + xit(ivx) = 1000. + else + xit(ivx) = xit(ivx)+tnote(in) + end if +c +c Flag xtups +c + if (nodur(ivx,cnn(ivx)) .eq. 0) then + if (.not.inxtup(ivx)) then +c +c First note of xtup, not at start of bar. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = xit(ivx)-tnote(in) +c +c (Note: can't be on last note in voice, so xit(ivx) <> 1000) +c Put xtuplet in a forced beam if not already in forced beam +c + if (nfb(ivx) .gt. 0) then + do 70 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c NO explicit bm; put one in +c + go to 71 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit bm. Don't put one +c + go to 72 + end if +70 continue + end if +71 continue +c +c If here, no explicit bm, so put one in +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+tglp1, + * t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +72 continue + else if (inxtup(ivx)) then +c +c This test is sufficient because already know nodur>0 +c + inxtup(ivx) = .false. + if (infbmx(ivx)) then +c +c Xtup is in auto-forced beam, so end it +c + t2fb(ivx,ifbnow(ivx)) = + * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1 + infbmx(ivx) = .false. + end if + end if + if (btest(irest(ivxo(in),ipo(in)),24) .or. + * btest(irest(ivxo(in),ipo(in)),30)) then +c +c For staff jumped beam, flag the first note (lowest voice) at same time. +c Later will start new notes group here. +c + inj = in + if (ivxo(in) .gt. 1) then + do 40 iin = in-1 , 1 , -1 + if (to(iin)+tol .lt. to(in)) go to 41 + if (abs(to(iin)-to(in)) .lt. tol) then + inj = iin + go to 40 + end if +40 continue + end if +41 continue + irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29) + end if + in = in+1 + go to 5 +7 continue + ntot = in-1 + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = tnote(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(a)')' Greetings from PMXB' +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +c +c Done w/ list. Loop for parsing into note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c A manual loop to set space(ib) and istop(ib) +c +9 continue + + ivx = ivxo(min(in+1,ntot)) + ip = ipo(min(in+1,ntot)) + isl = islur(ivx,ip) + if (in.eq.ntot .or. ((ivx.eq.1 .and. + * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28) +c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then +c Bits 1-13: stmgx+Tupf._) +c 14: Down fermata, was F +c 15: Trill w/o "tr", was U + * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) ) +c +c Checking for start of 2nd part of jumped beam +c + * .or. btest(irest(ivx,ip),29) ) then +c +c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; +c flow out of if-loop and into block-wrapup +c +c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered +c voice, but it wasn't first in the list at the same time. So check if +c prior notes in list have same time +c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef +c changes on last note in the list? +c + if (btest(isl,15) .and. in.lt.ntot) then + do 50 iin = in , 1 , -1 + if (tno(iin) .gt. tol) then + in = iin + islur(ivx,ip) = ibclr(islur(ivx,ip),15) + islur(ivxo(in+1),ipo(in+1)) = + * ibset(islur(ivxo(in+1),ipo(in+1)),15) + go to 51 + end if +50 continue +51 continue + end if + if (space(ib) .lt. tol) then + space(ib) = tno(in) + squez(ib) = 1. + end if + istop(ib) = in + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the group, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart and istop are good, so finalize block +c + tstart(ib) = to(istart(ib)) + if (istop(ib) .eq. ntot) go to 15 + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space and squeeze-factor for upcoming block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue + nb = ib +c +c Invert the list of places into ipl(0-7), making it easier to analyze a voice +c + do 13 in = 1 , ntot +c +c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. +c +c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) + ipl2(ivxo(in),ipo(in)) = in +13 continue +c +c Compute elemskips from start of bar to each note in the bar, for beam slopes +c + eskzb = 0. + ib = 1 + do 30 in = 1 , ntot + if (in .eq. istart(ib)) then + deskb = squez(ib)*feon(space(ib)/squez(ib)) + else if (tno(in-1) .gt. tol) then + eskzb = eskzb+deskb + end if + eskz(ivxo(in),ipo(in)) = eskzb + eskz2(ivxo(in),ipo(in)) = eskzb + if (in .eq. istop(ib)) then + eskzb = eskzb+deskb + ib = ib+1 + end if +30 continue +c +c Debug writes +c +c print* +c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) +c print*,'PMXB has now got blocks' +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, +c * in=1,ntot) +c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) +c +c +c Analyze for beams. +c + do 20 iv = 1 , nv + do 20 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + numbms(ivx) = 0 + mapfb(1) = 0 + mapfb(2) = 0 + mapfb(3) = 0 + mapfb(4) = 0 +c +c First forced beams. +c + if (nfb(ivx) .gt. 0) then +c +c tglp2 is time from start of gulp to end of current bar. +c + nfbbar = 0 + do 80 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81 + nfbbar = nfbbar+1 + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) +c +c Times from beginning of bar +c + itbb1 = int(t1fb(ivx,ifb)-tglp1+tol) + itbb2 = int(t2fb(ivx,ifb)-tglp1+tol) + do 83 ip = 1 , nn(ivx) + if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then + nip1fb = ip + do 84 ip1 = ip , nn(ivx) + inip1 = ipl2(ivx,ip1) + if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then + nip2fb = ip1 + itbb3 = itbb2-2 + go to 85 + end if +84 continue + end if +83 continue + print* + print*,'Timing problem w/ forced beams' + write(15,'(/a)')'Timing problem w/ forced beams' +85 continue + call logbeam(numnew,nip1fb,nip2fb) +c +c Set up mapfb for forced beam just logged: +c + ib1 = itbb1/2 + ib2 = itbb3/2 + ibrep = lenbar/ibmrep/2 + do 86 irep = 1 , ibmrep + ib1now = max(0,ib1-(irep-1)*ibrep) + ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep) + mapnow = 0 + do 87 ib = ib1now , ib2now + mapnow = ibset(mapnow,ib) +87 continue + mapfb(irep) = ior(mapfb(irep),mapnow) +86 continue +c +c Since we are cycling thru forced beams, for those that start with a rest and +c have height & slope adjustments, move adjustments to next note. +c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at +c start of beam +c + if (btest(irest(ivx,nip1fb),0)) then +c call setbits(ipl(ivx,nip1fb+1),6,11, +c * igetbits(ipl(ivx,nip1fb),6,11)) +c call setbits(ipl(ivx,nip1fb+1),6,17, +c * igetbits(ipl(ivx,nip1fb),6,17)) +c call setbits(islur(ivx,nip1fb+1),2,27, +c * igetbits(islur(ivx,nip1fb),2,27)) + do 88 kp = nip1fb+1 , nip2fb + call setbits(ipl(ivx,kp),6,11, + * igetbits(ipl(ivx,nip1fb),6,11)) + call setbits(ipl(ivx,kp),6,17, + * igetbits(ipl(ivx,nip1fb),6,17)) + call setbits(islur(ivx,kp),2,27, + * igetbits(islur(ivx,nip1fb),2,27)) +88 continue + end if +80 continue +81 continue +c +c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. +c Remember, makeabar is called 1/bar, and it calls findbeam once per voice. +c + if (nfbbar .gt. 0) then + nfb(ivx) = nfb(ivx)-nfbbar + do 82 ifb = 1 , nfb(ivx) + t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar) + t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar) + ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar) +82 continue + end if + end if + ifb = 0 +c +c Done with forced beam masks for this bar and voice. Now get normal beams. +c + call findbeam(ibmrep,numbms,mapfb) +20 continue + return + end + subroutine make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp, + * isbj2 + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,issig,rpndot,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer istart(80),istop(80),iaskb(nm),numbms(nm), + * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2) + character*1 ulfbq,udqq,clefq(nm),slurudq + character*8 noteq + character*79 cwrq(nm),notexq,inameq + character*20 voltxtq + common /comoct/ noctup + character*80 soutq,headrq,lowerq + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical bspend,lower,cwrest(nm),vxtup, + * isgrace,isclef,nofirst,iscln,isdot,isflag, + * isacc,isfirst,flgndb,btest,stemup,upslur, + * isgaft,isarp,isrshft,isaccs,iscacc, + * lowdot,flipend,iscwr,isdotted,beamon1(nm) + real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80), + * squez(80) + logical cwrferm,drawbm + common /comcwrf/ cwrferm(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur + * ,WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + logical secondgrace +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c Set up main ib loop within which a block (notes group) is written +c + do 25 iv = 1 , nv + do 25 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ibmcnt(ivx) = 1 + ibmcnt1(ivx) = 1 + beamon(ivx) = .false. + beamon1(ivx) = .false. + nornb(ivx) = 0 + iaskb(ivx) = 1 + vxtup(ivx) = .false. + drawbm(ivx) = .true. +25 continue + naskb = 0 + ifig(1) = 1 + ifig(2) = 1 + ixtup = 0 + bspend = .false. + iscwr = .false. + rpndot = .false. + do 16 ib = 1 , nb +c +c Check for segno +c + if (btest(iornq(1,ipo(istart(ib))),4) .and. + * ivxo(istart(ib)).eq.1) then + if (noffseg.le.-10) then + write(noteq(1:5),'(1H{,i3,1H})')noffseg + lnoten = 5 + else if (noffseg.lt.0 .or. noffseg.ge.10) then + write(noteq(1:4),'(1H{,i2,1H})')noffseg + lnoten = 4 + else + write(noteq(1:1),'(i1)')noffseg + lnoten = 1 + end if + notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9' + lnote = 15+lnoten + do 130 iv = 2 , nv + if (lnote .gt. 60) then + if (islast) write(11,'(a)')notexq(1:lnote)//'%' + notexq = sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnoten+9 + else + notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnote+lnoten+9 + end if +130 continue + if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en' + lnote = 0 + end if +c +c Check for new clefs +c + isclef = .false. + if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15)) + * then +c +c In preceding line, fl32 gave wrong result for ... .gt.0 !!! +c + do 140 in = istart(ib) , istop(ib) + if (btest(islur(ivxo(in),ipo(in)),11)) then + call wsclef(ivxo(in),ninow,clefq, + * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) + end if +140 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + isclef = .true. + end if +c +c Start a notes group. We're just gonna define every one using pnotes{n}, +c where \def\pnotes#1{\vnotes#1\elemskip} +c + soutq = sq//'pnotes{' + eonsqz = squez(ib)*feon(space(ib)/squez(ib)) + if (eonsqz .gt. 9.995) then + write(soutq(9:12),'(f4.1)')eonsqz + else if (eonsqz .gt. 0.995) then + write(soutq(9:12),'(f4.2)')eonsqz + else if (eonsqz .gt. 0.095) then + soutq = soutq(1:8)//'0.' + write(soutq(11:12),'(i2)')nint(100*eonsqz) + else + soutq = soutq(1:8)//'0.0' + write(soutq(12:12),'(i1)')nint(100*eonsqz) + end if + soutq = soutq(1:12)//'}' + lsout = 13 +c +c Check whole block, flag accidentals etc that are too close, one per *time*. +c Note about bar starts and after rpt's/boublebars: There is an afterruleskip +c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so +c (dotsfac*wheadpt) is presumed to be filled up. +c + in = istart(ib)-1 + itrpt = -1 + itsig = -1 +c +c Begin big manual loop over notes in this block; ends at 112 +c +111 in = in+1 + if (in .gt. istop(ib)) go to 112 + ip = ipo(in) + ivx = ivxo(in) + if (ivx .le. nv) then + iv = ivx + else + do 128 iv = 1 , nv + if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129 +128 continue + print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2) + print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2) + stop + end if +129 continue +c +c Call precrd here so we know how much space to add for accid's in chords +c After calling precrd, icashft>0 means there is a shifted chordal accid (incl. +c main note. +c +c To call precrd, need up-downness, so must track if in beam. +c +c Deal w/ staff-jumping beams later +c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. +c * btest(nacc(ivx,ip),21)) then +c if (.not.btest(irest(ivx,ip),24)) then + if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx) + * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then + beamon1(ivx)=.true. + end if + icashft = 0 + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. +c + if (beamon1(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)), + * .false.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .false.,icashft) + end if + end if +c +c Turn beam off? +c + if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then + beamon1(ivx) = .false. + ibmcnt1(ivx) = ibmcnt1(ivx)+1 + end if +c +c Remember, rpts & internal sigs can only come at start of (internal) block +c + isacc = iand(nacc(ivx,ip),3).gt.0 + * .and. .not.btest(nacc(ivx,ip),17) + * .and. .not.btest(ipl(ivx,ip),10) +c +c i.e., do not set for chord. Now check for "(" as ornament on main note, +c +c!!! Need to do this for chord notes too. Maybe in chkarp? +c + isaccs = isacc .or. btest(iornq(ivx,ip),0) +c +c 5/15/02 Add check for ) ornament of prior note. +c 5/16 Nope...fails when grace intervenes. +c if (ip .gt. 1) then +c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) +c end if + isarp = btest(iornq(ivx,ip),27) + iscacc = .false. + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord here; check for arpeggios and accidentals. Note accid shifts are +c not of concern here, only whether there's an accid, whick causes iscacc=.true. +c + iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and. + * .not.btest(nacc(ivx,ip),17) + call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) + end if +c +c When we get motivated, will do spacing for arpeggios here. +c + if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) + * itrpt = nint(to(in)) + issig = btest(ipl(ivx,ip),28) + if (ivx.eq.1 .and. issig) itsig = nint(to(in)) + isgrace = btest(islur(ivx,ip),4) .and. + * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31) + isgaft = .false. + if (ip .gt. 1) then + xnd = tnote(ipl2(ivx,ip-1)) + isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31) + isgrace = isgrace .or. isgaft + end if + iscln = isclef .and. btest(islur(ivx,ip),11) +c +c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd +c + isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol + if (isflag) + * isflag = .not.btest(irest(ivx,ip-1),0) + * .and. udqq(nolev(ivx,ip-1), + * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u' + if (isflag) then + do 116 ibmchk = 1 , numbms(ivx) + if (ip-1 .lt. ibm1(ivx,ibmchk)) then + go to 117 +c +c Add check for non-beamed xtuplets. May be problem with stem direction. +c +c else if (ip-1.le.ibm2(ivx,ibmchk)) then + else if (ip-1.le.ibm2(ivx,ibmchk) .and. + * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then + isflag = .false. + go to 117 + end if +116 continue + end if +117 continue +c +c If isflag, then won't need to check for dot on prev. note. +c +c 5/16/02 ??? Try using this for ) ornament. +c + isflag = isflag .or. btest(iornq(ivx,ip-1),13) + isdot = ip.gt.1 + if (isdot) isdot = isdotted(nodur,ivx,ip-1) + isrshft = ip .gt. 1 + if (isrshft) isrshft = btest(irest(ivx,ip-1),20) + if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or. + * isdot.or.btest(iornq(ivx,ip),26).or. + * btest(irest(ivx,ip),21).or.isarp.or. + * btest(irest(ivx,ip),27).or.iscacc)) go to 111 +c +c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. +c Compute pts, the total occupied space including prior notehead. +c + wheadpt1 = wheadpt*fullsize(iv) + pts = wheadpt1 +c +c Set up for possible cautionary accidental here +c + if (isaccs .or. iscacc) then + if (.not.btest(iornq(ivx,ip),31)) then + taccfac = accfac + else + taccfac = 1.4*accfac + end if + end if + if (isgrace) then + secondgrace = .false. + do 122 ig = 1 , ngrace + if (.not. isgaft) then + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123 + else if (ip .gt. 1) then + if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123 + end if +122 continue + print*,'Problem finding grace index in makeabar' + stop +123 continue +c +c wgr = distance to backspace (in headwidths), less main acc. +c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. +c spgr = total space needed (w/o main acc). +c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. +c + if (nng(ig) .eq. 1) then + wgr = grafac + if (multg(ig) .eq. 0) wgr = wgr-.4 + else + wgr = nng(ig)*emgfac + do 126 ing = 2 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +126 continue + end if + if (graspace(ig) .gt. 0.) then +c +c User-defined space before grace +c + wgr = wgr+graspace(ig) + end if + ptgr(ig) = wgr*wheadpt1 + spgr = ptgr(ig)+xb4fac*wheadpt1 +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1 + if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac + pts = pts+spgr +c +c Special check for after-grace on ip-1 and normal on ip. Must go back thru +c loop again for the normal grace. +c + if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then + if (ipg(ig+1).eq.ip) then + secondgrace = .true. + ig = ig+1 + go to 123 + end if + end if + end if + if (iscln) then + pts = pts+clefac*wheadpt1 +c +c How far to backspace when printing the clef +c + ptclef(ivx) = 0. +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) + * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1 + if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr + end if + if (isrshft) then + pts = pts+rtshfac*wheadpt1 + else if (isflag) then + pts = pts+flagfac*wheadpt1 + else if (isdot) then + pts = pts+dotfac*wheadpt1 + end if + if (abs(to(in)-itrpt) .lt. tol) then +c +c Repeat, need a little extra space +c + pts = pts+dotsfac*wheadpt1 + end if + if (isarp) then + pts = pts+arpfac*wheadpt1 + end if +c +c Add in padding space +c + pts = pts+xspfac*wheadpt1 +c +c Now done with all items needing space except accidentals, +c accidental shifts, and left-notehead-shifts, and will later +c subtract a notehead if at start of bar. +c +c Get available space in elemskips (esk) +c +c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. +c * to(in) .eq. itsig + isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or. + * abs(to(in)-itsig).lt.tol + if (isfirst) then +c +c At start of bar or after repeat sign or new signature +c +c if (to(in) .eq. itsig) then + if (abs(to(in)-itsig).lt.tol) then + esk = 0. + else + esk = fbar + end if + else +c +c Not 1st note of bar +c + esk = eskz(ivx,ip)-eskz(ivx,ip-1) + end if + if (isgrace) then +c +c Since graces can be very long, cannot assume no interference if prior +c note uses >1 noteskip. So must get elsk's back to prior note, whether or +c not it used only one noteskip. +c <>???? +c +c 10/8/05 Kluge to not zero out esk if in xtup +c + esksav = esk + if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and. +c * to(in).ne.itsig) + * abs(to(in)-itsig).gt.tol) + * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) + if (abs(esk) .lt. tol) esk = esksav + end if +c +c Done getting available elemskips. Remove headwidth if first. Must do here +c rather than earlier since check uses isfirst +c + if (isfirst) pts = pts-wheadpt1 +c +c Deal with accidental shifts and left-notehead shifts +c + if (btest(ipl(ivx,ip),10)) then +c +c In a chord +c + ptsl = 0. + if (btest(irest(ivx,ip),27)) ptsl = wheadpt1 + ptsadd = max(ptsl,icashft*.05*wheadpt1) +c +c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK +c + else +c +c Not in a chord +c + ihshft = 0 + if (isaccs) then + ihshft = igetbits(nacc(ivx,ip),7,10) +c if (ihshft .ne. 0) ihshft = max(0,64-ihshft) + if (ihshft .ne. 0) ihshft = max(0,107-ihshft) + end if +c +c Check for left-shifted main note +c + if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft) + ptsadd = ihshft*.05*wheadpt1 + end if + pts = pts+ptsadd + if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd + if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd +c +c Left-shifted, non-chord note before? +c + if (ip .gt. 1) then + if (.not.btest(ipl(ivx,ip-1),10) .and. + * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1 + end if +c +c Try big accidentals first +c + ptbneed = pts + if (isaccs .or. iscacc) then + ptbneed = ptbneed+wheadpt1*bacfac + end if + if (poenom*esk .gt. ptbneed) then +c +c Set flag for big accidental +c + if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3) + go to 99 + end if +c +c Cannot use big, so try small +c + ptsneed = pts + if (isaccs .or. iscacc) then + ptsneed = ptsneed+taccfac*wheadpt1 + end if + if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, + * esk,fixednew,scaldold,0.,.false.) +99 continue + if (btest(iornq(ivx,ip),26)) then +c +c User-defined space. Warning, "zero" may change value in addask! +c + zero = 0. + call addask(to(in),ptsneed,zero, + * fixednew,scaldold,tglp1,.true.) + end if +c +c End of big manual loop over "in" for accidental checking +c + go to 111 +112 continue +c +c End of ask analysis for this block. +c +c Adjust eskz if there are added spaces. Corrects length of xtup brackets. +c + if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom) +c +c Check for internal repeat or sig change. +c + if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then + iirpt = iand(islur(1,ipo(istart(ib))),67109216) + if (iirpt .gt. 0) then +c +c Internal repeat +c + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (iirpt .eq. 96) then + if (islast) write(11,'(a)')sq//'leftrightrepeat' + fixednew = fixednew+lrrptfac*wheadpt + else if (btest(iirpt,5)) then + if (islast) write(11,'(a)')sq//'leftrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,6)) then + if (islast) write(11,'(a)')sq//'rightrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,8)) then + if (islast) write(11,'(a)')sq//'doublebar' + else + print*,'Unexpected mid-bar repeat command R*' + call stop1() + end if + scaldold = scaldold-fbar + end if + if (btest(ipl(1,ipo(istart(ib))),28)) then +c +c Internal signature change. +c + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'//sq//'afterruleskip}%' + lnote = 0 + end if + end if + flgndb = .false. +c +c Done with start-of-block stuff. Begin main loop over voices. +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + icm = midchan(iv,kv) +c +c A rather klugey way to set flag for figure in this voice +c Must always check figbass before figchk. +c + if (figbass) then + ivf = 0 + if (ivx .eq. 1) then + ivf = 1 + else if (ivx .eq. ivxfig2) then + ivf = 2 + end if + if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0 + end if + if (ivx .gt. 1) then + if (ivx .le. nv) then + call addstr(sepsymq(iv-1),1,soutq,lsout) + else + call addstr(sq//'nextvoice',10,soutq,lsout) + end if + end if + if (ihdht.gt.0 .and. ivx.eq.nv) then +c +c Write header. First adjust height if needed to miss barno. +c + if (bar1syst .and. iline.ne.1) then + ihdht = 15+irzbnd+isnx + end if +c +c Add user-defined vertical shift +c + ihdht = ihdht+ihdvrt + lchead = lenstr(headrq,80) + notexq = sq//'zcharnote{' + write(notexq(12:13),'(i2)')ihdht + notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt ' + call addstr(notexq,34,soutq,lsout) + call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout) + ihdht = 0 + end if + if (lower .and. ivx.eq.nv) then + lclow = lenstr(lowerq,80) + call addstr(sq//'zcharnote{-6}{'// + * sq//'tempo'//sq//'kern-10pt '// + * lowerq(1:lclow)//'}',33+lclow,soutq,lsout) + lower=.false. + end if + tnow = tstart(ib) + nofirst = .true. +c +c Done setting up voice ivx for start of block ib. Loop over notes in voice. +c + do 10 jn = istart(ib), istop(ib) + if (ivxo(jn) .ne. ivx) go to 10 + ip = ipo(jn) +c +c May have problem with not initializing islhgt, so do it here +c + islhgt = 0 +c + if (nofirst) then + noctup = 0 + if (ncmid(iv,ip) .eq. 23) noctup = -2 + nofirst = .false. + end if +c +c Check for internal floating figure (before last note of group). +c +12 if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol) + * then +c +c Bypassed figure location. Backup, place fig, return. +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq, + * lsout) + go to 12 + end if + end if + end if +c +c Put in \sk if needed +c + if (to(jn) .gt. tnow+tol) then + call addstr(sq//'sk',3,soutq,lsout) + tnow = tnow+space(ib) + go to 12 + end if +c +c Check for user-defined shifts +c + if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16)) + * call putshft(ivx,.true.,soutq,lsout) +21 if (iaskb(ivx).le.naskb .and. + * tnow.gt.task(iaskb(ivx))-tol) then + if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then +c +c Insert placeholder for accidental skip +c + call addstr(sq//'ask ',9,soutq,lsout) + nasksys = nasksys+1 + wasksys(nasksys) = wask(iaskb(ivx)) + if (wask(iaskb(ivx)) .gt. 0.) then + elasksys(nasksys) = elask(iaskb(ivx)) + else +c +c This is a signal to permit negative ask's. Should really have elask>=0. +c + elasksys(nasksys) = -elask(iaskb(ivx)) + end if + end if +c +c May have skipped some task's in earlier blocks (due to void voice) +c + iaskb(ivx) = iaskb(ivx)+1 + go to 21 + end if + if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. + * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then +c +c Figure on a note. NB: later special check for late figs. +c + call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout) + end if + end if + end if +c +c Check for new clef here. +c + if (isclef .and. btest(islur(ivx,ip),11)) then +c print*,'At clef insertion, ptclef:',ptclef(iv) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{-' + if (ptclef(iv) .lt. 9.95) then + write(notexq(7:9),'(f3.1)')ptclef(iv) + lnote = 9 + else + write(notexq(7:10),'(f4.1)')ptclef(iv) + lnote = 10 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) +c print*,'Just added: ',notexq(1:lnote) + end if + call clefsym(islur(iv,ip),notexq,lnote,nclef) + call addstr(notexq,lnote,soutq,lsout) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{' + if (ptclef(iv) .lt. 9.95) then + write(notexq(6:8),'(f3.1)')ptclef(iv) + lnote = 8 + else + write(notexq(6:9),'(f4.1)')ptclef(iv) + lnote = 9 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) + end if + end if +c +c Checking for literal TeX string BEFORE starting beams!! +c + if (btest(islur(ivx,ip),16)) then + do 124 il = 1 , nlit + if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125 +124 continue + print*,'Problem finding index for literal string' + call stop1() +125 continue +c +c Write a type 1 tex string. +c + if (lenlit(il) .lt. 71) then +c +c Add normally +c + call addstr(litq(il),lenlit(il),soutq,lsout) + else +c +c Longer than 71. Write souq, Write string, start new soutq. +c + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%' + lsout = 0 + end if + end if +c +c Arpeggio on a main (non-chordal) note? +c + if (btest(iornq(ivx,ip),27)) then +c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), + call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip), + * soutq,lsout) + end if +c +c See if a beam starts here +c + 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 +c +c Not a jump start +c + call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) +c +c Shift beam start if notehead was shifted +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) + else +c +c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set +c to 0 at end of first part of jump beam +c + ivbj2 = ivx +c +c Check for xtup since we bypassed beamstrt wherein vxtup is normally set +c + if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2) + * vxtup(ivx) = .true. +c +c Since beamstrt is not called, and drawbm is normally set there, need to set +c it here. This could cause problems if someone tries a staff-jumping, +c unbarred beam, which I'll deal with when it comes up. +c + drawbm(ivx) = .true. + end if + if (ixrest(ivx) .eq. 0) then + beamon(ivx) = .true. + bspend = .true. + if (.not.btest(irest(ivx,ip),24))bspend = .true. + end if + end if +c +c Setup for chords and possible slurs in chords +c + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Just rerun precrd. Klunky, but saves +c me from tracking down errors instroduced when I moved 1st call +c forward for accidental spacing analysis. +c + if (beamon(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)), + * .true.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .true.,icashft) + end if + end if +c +c Is there slur or grace activity? +c + isgrace = btest(islur(ivx,ip),4) + if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31) +c +c isgrace if not 1st note in bar and previous note has Way-after grace. +c + if (btest(islur(ivx,ip),0) .or. isgrace) then + if (btest(islur(ivx,ip),0)) then + if (fontslur) then +c +c Call routine for non-postscript slurs +c + call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + else +c +c Postscript slurs +c + call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3, + * isdat4,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + end if + end if + if (isgrace) then +c +c Grace note. +c + iphold = ip + isgrace = .false. + if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31) + if (isgrace) iphold = iphold-1 + isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31) + * .and..not.btest(ipl(ivx,ip),29)) +c +c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace +c on current note. Do A-grace on current note, and W-grace at barend, later. +c + if (isgrace) then + call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,iphold),.false., + * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx), + * tnote(ipl2(ivx,ip)),ulq) + if (slurg(ig)) then +c +c Terminate slur started in dograce. Get direction of main note stem +c + if (.not.beamon(ivx)) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. + * tnote(ipl2(ivx,ip)).gt.63 + call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0, + * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur) + end if + end if + end if + if (btest(iornq(ivx,ip),24)) then +c +c Start slur on main note for After- or Way-after-grace. +c +c???? ndxslur = log2(33554431-listslur) + ndxslur = log2(16777215-listslur) +c +c Get note name +c + call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) +c +c Get slur direction +c + slurudq = 'u' + if (.not.beamon(ivx)) then + if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd' + else + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd' + end if +c +cc Replace ndxslur by 11-ndxslur when printing only. +c Replace ndxslur by 23-ndxslur when printing only. +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c notexq = sq//'islur'//slurudq//chax(59-ndxslur) + notexq = sq//'islur'//slurudq//chax(71-ndxslur) + * //noteq(1:lnoten) + call addstr(notexq,8+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + else + notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + end if +c call setbits(ipl(ivx,ip),4,23,ndxslur) + call setbits(ipl(ivx,ip),5,23,ndxslur) + if (btest(ipl(ivx,ip),31)) +c +c Starting slur on W-grace on THIS note. Record ndxslur. +c + * listslur = ibset(listslur,ndxslur) + end if + end if +c +c Process dynamic marks +c + if (btest(irest(ivx,ip),26)) then + call dodyn(ivx,ip, + * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip), + * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq, + * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout) + end if +c +c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. +c + if (btest(ipl(ivx,ip),10)) then +c +c Need a duration to set type of note head +c +c if (.not. vxtup(ivx)) then +c +c Clumsy test, but vxtup is not set until main note is processed. +c + if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then + nodu = nodur(ivx,ip) +c else if (mult(ivx,ip) .lt. 0) then + else if (iand(mult(ivx,ip),15)-8 .lt. 0) then + nodu = 32 + else + nodu = 16 + end if + call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout, + * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv, + * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen, + * btest(nacc(ivx,ip),27),nacc(ivx,ip)) + end if +c +c Now that chords are done, add stuff to midi file +c +c if (ismidi) call addmidi(icm,nolev(ivx,ip), + if (ismidi) call addmidi(icm, + * nolev(ivx,ip)-iTransAmt(instno(iv)), +c + * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)), + * btest(irest(ivx,ip),0),.false.) +c +c Check for breath or caesura +c + if (btest(iornq(ivx,ip),28)) then + call putcb(ivx,ip,notexq,lnote) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Check for main-note ornaments. ')' on dotted notes go in with note, not here. +c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD +c + isacc = iand(iornq(ivx,ip),4194287) .gt. 0 +c +c isacc=.true. if any ornament except segno +c + if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then +c +c If ). is only ornament, bypass. If with others, temporarirly zero the bit. +c + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (iand(iornq(ivx,ip),516079) .eq. 0) then +c +c ). is the only non-segno ornament +c + isacc = .false. + else +c +c There are other ornaments in addition +c + rpndot = .true. + iornq(ivx,ip) = ibclr(iornq(ivx,ip),13) + end if + end if + end if + if (isacc .and. .not.cwrferm(ivx)) then +c +c Check for centered whole-bar rest with fermata (bits 10 or 14). +c + if (iand(iornq(ivx,ip),17408).gt.0 + * .and. btest(irest(ivx,ip),0) .and. + * nodur(ivx,ip).eq.lenbar .and. + * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then + cwrferm(ivx) = .true. + go to 30 + end if + call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip), + * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen, + * notexq,lnote,ip,islhgt,beamon(ivx), + * btest(ipl(ivx,ip),10)) + call addstr(notexq,lnote,soutq,lsout) + end if + if (rpndot) then + iornq(ivx,ip) = ibset(iornq(ivx,ip),13) + rpndot = .false. + end if +30 continue +c +c Check for main note accidental +c + if (iand(nacc(ivx,ip),3).gt.0 .and. + * .not.btest(nacc(ivx,ip),17)) then + ihshft = igetbits(nacc(ivx,ip),7,10) + if (ihshft .ne. 0) ihshft=ihshft-107 + if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8)) +c +c Not a chord, and left-shifted main note, so left-shift accid +c + * ihshft = ihshft-20 + call doacc(ihshft,igetbits(nacc(ivx,ip),6,4), + * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip), + * btest(irest(ivx,ip),31)) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Lower dot for lower-voice notes. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest +c. 5. Flag (lowdot) is set to true +c 6. Not in an xtuplet +c + if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv + * .and. nodur(ivx,ip).ne.0) then + if (.not.btest(irest(ivx,ip),0) .and. + * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and. + * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then + if (btest(irest(ivx,ip),19)) then +c +c Note already in movdot list. Drop by 2. +c + updot(ivx,ndotmv(ivx)+1) = + * updot(ivx,ndotmv(ivx)+1)-2. + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout, + * igetbits(islur(ivx,ip),1,3)) + end if + end if + end if +c +c Check for dotted notes with moved dots +c + if (btest(irest(ivx,ip),19)) then + ndotmv(ivx) = ndotmv(ivx)+1 + call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)), + * soutq,lsout,igetbits(islur(ivx,ip),1,3)) + end if +c +c Stemlength shortening? +c + if (btest(mult(ivx,ip),27)) then + stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5 + call addstr(sq//'stemlength{',12,soutq,lsout) + write(notexq,'(f4.2)')stemshort + call addstr(notexq(1:4)//'}',5,soutq,lsout) + else if (ip .gt. 1) then + if (btest(mult(ivx,ip-1),27)) +c +c Cancel shortening. Looks like it gets automatically restored if new inst. or +c new line, so no need to worry about affecting other lines +c + * call addstr(sq//'stemlength{4.66}',17,soutq,lsout) + end if +c +c Zero out slur-height marker for raising ornaments +c + islhgt = 0 +c +c Now start with spacing notes. Is a beam start pending? +c + if (bspend .and. + * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then + if (ixrest(ivx) .eq. 4) then +c +c Special path for single note at end of otherwise beamed xtup +c + ixrest(ivx) = 0 + else + call beamn1(notexq,lnote) + end if + bspend = .false. +c +c Is a beam ending? +c + else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then + * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or. + * btest(nacc(ivx,ip),20))) then + if (bspend) then +c +c Must be a single-note ending of a jump-beam +c + bspend = .false. + end if + call beamend(notexq,lnote) + if (.not.btest(nacc(ivx,ip),20)) then + vxtup(ivx) = .false. + nornb(ivx) = 0 + ibmcnt(ivx) = ibmcnt(ivx)+1 + beamon(ivx) = .false. + end if +c +c Or if we're in the middle of a beam +c + else if (numbms(ivx).gt.0 .and. beamon(ivx)) then + call beamid(notexq,lnote) +c +c Or whole-bar rest +c + else if (btest(irest(ivx,ip),0) + * .and. nodur(ivx,ip).eq.lenbar + * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0) + * .and..not.btest(irest(ivx,ip),25) + * .and..not.btest(islur(ivx,ip),29)) then +c +c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp +c + cwrest(ivx) = .true. + iscwr = .true. + call notex(cwrq(ivx),lcwr(ivx)) + tnow = tnow+lenbar + go to 10 + else if (ixrest(ivx) .eq. 0) then +c +c Before writing note or rest, check for keyboard rest height adjustment. +c Conditions are 0. This is a non-blank rest +c 1. kbdrests = .true. +c 2. There are two voices on the staff +c 3. No user-def height adjustments have been applied (nolev<50) +cc 4. Not last note in bar +cc 5. Followed by note (add better test later) +c + if (kbdrests .and. btest(irest(ivx,ip),0) .and. + * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. +c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) +c * .and. .not.(btest(irest(ivx,ip+1),0))) then + * nolev(ivx,ip).le.50) then +c +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 + end if +2 continue +c +c Write a separate note or rest +c + call notex(notexq,lnote) + end if +c +c Right offset? This may cause trouble +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (ixrest(ivx).eq.0 .and. lnote.gt. 0) + * call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) +c +c Terminate user-defined offsets. Fix format +c + if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) + * call putshft(ivx,.false.,soutq,lsout) +c +c Deal with After- and Way-after-graces. First, if end of bar, compute space +c needed since it wasn't done during general ask-checks. If extra space is +c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. +c But will still need to add extra space as hardspace. +c + if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or. + * btest(ipl(ivx,ip),29))) then + do 77 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78 +77 continue + print*,'Problem finding grace index at "do 77"' + call stop1() +78 continue +c +c Get elemskip to end of bar. WON'T WORK IF XTUPS !! +c + esk = 0. + do 40 iib = ib , nb + if (iib .eq. ib) then + itleft = nint(to(ipl2(ivx,ip))) + else + itleft = nint(tstart(ib)) + end if + if (iib .lt. nb) then + itright = nint(tstart(iib+1)) + else + itright = lenbar + end if + esk = esk+feon(space(ib))* + * (itright-itleft)/space(ib) +40 continue + ptsavail = poenom*esk-wheadpt + if (nng(ig) .eq. 1) then + wgr = grafac + else + wgr = nng(ig)*emgfac + do 41 ing = 1 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +41 continue + end if + ptgr(ig) = wgr*wheadpt + ptsneed = (wgr+0.5)*wheadpt + ptsndg(ivx) = 0. + if (ptsavail .lt. ptsneed) then + ptsndg(ivx) = ptsneed + eskndg(ivx) = esk + if (btest(ipl(ivx,ip),31)) then +c +c Convert GW to GA +c + ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29) + end if + end if + end if +c +c Check for GA +c + if (btest(ipl(ivx,ip),29)) + * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,ip),.false., + * .false.,0,0,0,0,0,0,0.,ulq) +c +c Update running time +c + tnow = tnow+space(ib) +10 continue +c +c Have finished last note in this voice and block +c + itendb = nint(to(istop(ib))+space(ib)) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 +17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then +c +c There's at least one figure left. offnsk could be <0 +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout) + go to 17 + end if + end if +c +c Check for flag, dot, or upstem on last note of bar. +c + if (ib .eq. nb) then + ip = ipo(ipl2(ivx,nn(ivx))) + flgndv(ivx) = 0. + if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then + if (space(ib) .lt. 16.-tol) then +c +c Note in last space, smaller than a quarter note. +c + if ((.not.btest(irest(ivx,ip),0) .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') + * .or. isdotted(nodur,ivx,ip)) then +c +c Upstem non-rest, or dotted +c + if (numbms(ivx).gt.0 + * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx))) + * .and. .not.isdotted(nodur,ivx,ip)) + * then +c +c In beam and not dotted, so use smaller space +c + flgndv(ivx) = upstmfac + else + flgndv(ivx) = flagfac + end if + end if + else +c +c Last space, nonflagged (no beam) only worry dot or up +c + if (isdotted(nodur,ivx,ip)) then + flgndv(ivx) = flagfac + else if (tnote(ipl2(ivx,ip)).lt.64 .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') then +c +c Upstem on last note , non-flagged +c + flgndv(ivx) = upstmfac + end if + end if + end if +c +c Check for right-shifted chordal note +c + if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac + flgndb = flgndb .or. flgndv(ivx).gt.0. + if (ismidi) then +c +c For midi, set flags for accidentals on last note of bar. Assume they affect +c first note of next bar whether or not tied. +c Note has already been done, so next entry into addmidi is 1st in new bar. +c First do main note, then chord notes +c +c Gyrations needed to account for multi-bar tied full-bar notes? +cc Old old lbacc(icm) = iand(nacc(ivx,ip),7) +c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) +c + if (iand(nacc(ivx,ip),7) .gt. 0) then +c +c Explicit accidental on last main note in bar +c + do 55 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56 +55 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolev(ivx,ip) + jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7)) + end if +56 continue + if (btest(ipl(ivx,ip),10) .and. crdacc) then + do 57 icrd = icrd1 , icrd2 + iacc = igetbits(icrdat(icrd),3,20) + if (iacc .gt. 0) then +c +c Explicit accidental on chord note at end of bar +c + nolevc = igetbits(icrdat(icrd),7,12) + do 58 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolevc) go to 59 +58 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolevc + jaccbl(icm,naccbl(icm)) = iashft(iacc) + end if +59 continue +57 continue + end if +c if (lbacc(icm).eq.0 .and. accb4(icm)) then + do 65 kacc = 1 , naccim(icm) +c +c If naccim(icm)>0, +c possible implicit accidental from earlier in the bar. Check for prior accid +c in this bar at relevant note levels, main and chord notes. Only act if no +c explicit action from just above. Assuming any accid on last note in bar, +c either explicit or implicit, has same effect on 1st note of next bar. +c + if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66 + if (btest(ipl(ivx,ip),10)) then + do 67 icrd = icrd1 , icrd2 + if (iand(ishft(icrdat(icrd),-12),127) .eq. + * laccim(icm,kacc)) go to 66 +67 continue + end if + go to 65 +66 continue +c +c So far we know there is a main or chord note at level laccim(icm,kacc). So +c it will get a bl-accid if it didn't just already get one. +c + do 68 macc = 1 , naccbl(icm) + if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 +68 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = laccim(icm,kacc) + jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc) +65 continue + end if + end if +11 continue +c +c Close out the notes group +c + call addstr(sq//'en',3,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' +16 continue +c +c Check for way-after graces at end of bar. We could not link these to notes +c as in midbar since there is no note following grace! Also, set flag if +c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. +c + isgrace = .false. + do 75 iv = 1 , nv + nvmxsav(iv) = nvmx(iv) + do 75 kv = 1 , nvmx(iv) + ivmxsav(iv,kv) = ivmx(iv,kv) + ivx = ivmx(iv,kv) + ptsgnd = 0. + if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31)) + * .and. ptsndg(ivx).gt.0.) then + flgndb = .true. + if (ptsndg(ivx) .gt. ptsgnd) then + ptsgnd = ptsndg(ivx) + eskgnd = eskndg(ivx) + end if + end if + if (btest(ipl(ivx,nn(ivx)),31)) then +c +c This voice has a way-after grace here at end of bar +c + if (.not.isgrace) then +c +c This is the first one, so set up the string +c + isgrace = .true. + ivlast = 1 + soutq = sq//'znotes' + lsout = 7 + end if + do 76 iiv = ivlast , iv-1 + call addstr(sepsymq(iiv),1,soutq,lsout) +76 continue + ivlast = iv +c +c No need to put in 'nextvoice', even if 2 lines/staff +c + call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)), + * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true., + * .false.,0,0,0,0,0,0,0.,ulq) + end if +75 continue + if (isgrace) then + call addstr(sq//'en%',4,soutq,lsout) + if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout) + end if + lsout = 0 +c +c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest +c This has to be the only use of atnextbar +c +c if (ibar .eq. ibarmbr) then + if (ibar.eq.ibarmbr .and. islast) then +c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// +c * 'mbrest{',30,soutq,lsout) +c ndig = int(alog10(mbrest+.01))+1 +c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest +c lsout = lsout+ndig +c call addstr('}{',2,soutq,lsout) +c mtrspc = .5+xb4mbr +c xb4mbr = 0. +c if (mtrspc .eq. 0) then +c ndig = 1 +c else +c ndig = int(alog10(mtrspc+.01))+1 +c end if +c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc +c lsout = lsout+ndig +c call addstr('}0'//sq//'en}%',7,soutq,lsout) +c if (islast) write(11,'(a)')soutq(1:lsout) +c lsout = 0 +c ndig = int(alog10(mbrest-1+.01))+1 +c if (mbrest.eq.1) ndig=1 +c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') +c * sq//'advance'//sq//'barno',mbrest-1,'%' +c++ + soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes' + lsout = 22 + notexq = sq//'mbrest' + lnote = 7 + call istring(mbrest,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + mtrspc = .5+xb4mbr + xb4mbr = 0. + call istring(mtrspc,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len)//'0' + lnote = lnote+len+1 + do 62 iv = 1 , nv + call addstr(notexq,lnote,soutq,lsout) + if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout) +62 continue + call addstr(sq//'en}%',5,soutq,lsout) + write(11,'(a)')soutq(1:lsout) + lsout = 0 + if (mbrest .gt. 1) then + ndig = int(alog10(mbrest-1+.01))+1 + write(11,'(a14,i'//chax(48+ndig)//',a1)') + * sq//'advance'//sq//'barno',mbrest-1,'%' + end if + else if (iscwr) then +c +c Centered whole-bar rests +c + call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, + * soutq,lsout) + do 60 iv = 1 , nv + lnote = 0 + do 61 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (cwrest(ivx)) then + if (lnote .eq. 0) then + notexq = sq//'centerbar{' + lnote = 11 + end if + if (.not.cwrferm(ivx)) then + if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then +c +c Kluge to use new definitions for centered, stacked rests +c + if (cwrq(ivx)(2:10).eq.'liftpause' .or. + * cwrq(ivx)(2:10).eq.'liftPAuse') + * cwrq(ivx)(10:10) = 'c' + end if + notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+lcwr(ivx) + else +c +c Fermata on centered rest. Will need to fix up level. +c 12/6/07 shift it left so it's centered over rest +c +c notexq = notexq(1:lnote) +c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) +c lnote = lnote+11+lcwr(ivx) +c + notexq = notexq(1:lnote)//sq//'loffset{.39}{' + * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+26+lcwr(ivx) + cwrferm(ivx) = .false. + end if + end if +61 continue + if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1, + * soutq,lsout) + if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) +60 continue + call addstr(sq//'en}',4,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' + end if +c +c End of block for centered whole-bar rests and multi-bar rests +c +c If at end of block, save durations of last notes in bar, for possible use +c if clef changes at start of next bar +c + if (ibar .eq. nbars) then + do 63 iv = 1 , nv + do 63 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) +c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) + prevtn(ivx) = tnote(ipl2(ivx,nn(ivx))) +63 continue + end if +c +c Update time for midi. This is only used for the event track +c + if (ismidi) then + miditime = miditime+15*lenbar +c +c If pickup, write the real time signature to the event track. Cannot use +c mtrnuml since it was reset to 0, have to recompute it +c + if (lenb0 .eq. lenbar) + * call midievent('m',mtrdenl*lenb1/64,mtrdenl) + end if + return + end + subroutine makeabar() +c +c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for +c xtups, since only last note of xtup gets non-zero nodur, which +c corresponds to single note of full length of xtup. +c In this subroutine we make an ordered list of all notes in all voices. +c ilnc = list note counter +c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. +c to(ilnc) = real start time of note in PMX-units (64=whole note) +c tno(ilnc) = time to next event in the bar. +c tnote(ilnc) = actual duration of note +c Then run thru list, grouping consecutive notes into \notes groups ib. +c space(ib) = real time unit for the \notes group +c squez(ib) = factor on space to get effective space. This will be 1 if +c there is a note exactly spanning each interval of space, and +c <1 if not. +c Details: let eon = elemskips per noteskip (like length). Basic formula is +c eon = sqrt(space/2.) +c If tgovern >= space, then +c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). +c Time needed to give this eon using basic formula is +c teq = space**2/tgovern +c Factor on space to get teq is +c squez(ib) = space/tgovern +c The eon for each ib can then be computed based on time of space*squez. +c Iff squez = 1, there is a note spanning every increment in the \notes group. +c +c tnminb = minimum time span in the bar for increments spanned by notes, +c i.e., with squez=1. Use after parsing into line to decide if +c spacing needs to be "flattened" among notes groups. +c + common /comtol/ tol + parameter (nm=24,nkb=3999,maxblks=4000) + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + logical rest,firstline,newmeter,gotclef + integer cnn(nm),istart(80),istop(80) + real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600) + elskb = 0. + tnminb(ibarcnt) = 1000. + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv) +c + ilnc = 1 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cnn(ivx) = 1 + ivxo(ilnc) = ivx + ipo(ilnc) = 1 + to(ilnc) = 0. + tnote(ilnc) = fnote(nodur,ivx,1,nacc) + xit(ivx) = tnote(ilnc) + if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000. + ilnc = ilnc+1 +4 continue +c +c Build the list +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iv = 1 , nv + do 6 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + tminn = min(tmin,xit(ivx)) + if(tminn .lt. tmin) then + tmin = tminn + ivnext = ivx + end if +6 continue + if (tmin .gt. 999.) go to 7 + ivxo(ilnc) = ivnext + cnn(ivnext) = cnn(ivnext)+1 + ipo(ilnc) = cnn(ivnext) + to(ilnc) = tmin +c +c Check if this voice is done +c + tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc) + if (cnn(ivnext) .eq. nn(ivnext)) then + xit(ivnext) = 1000. + else + xit(ivnext) = xit(ivnext)+tnote(ilnc) + end if + ilnc = ilnc+1 + go to 5 +7 continue + ntot = ilnc-1 + if (ntot .gt. 600) then + call printl(' ') + call printl('Cannot have more than 600 notes per bar, stopping') + call stop1() + end if + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc) + tnote(ntot) = tno(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(tnote(in),in=1,ntot) +c +c Done w/ list. Initialize loop for building note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c Start the loop +c +9 continue + if (in .eq. ntot) then + if (space(ib) .lt. tol) then + space(ib) = tno(in) +c +c Last gap in bar is spanned by a note, so cannot need a squeeze. +c + squez(ib) = 1. + end if + istop(ib) = ntot +c +c From here flow out of this if block and into block-setup +c + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else +c +c Tentative space tno(in) is non-zero. Set squez, which will be kept (since +c it is a unique property of the particular increment starting here) : +c + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the space, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then +c +c Next increment has same space. Does it have same squez? +c + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) +c +c If it does have the same squez, loop, otherwise flow out +c + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart, istop, space, and squez are good, so close out block +c + tstart(ib) = to(istart(ib)) +c +c Compute elemskips assuming no flattening to increase min space. The formula +c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible +c flattening in pmxb), elsperns = squez*feon(space/squez) +c + elsperns = f1eon(space(ib)*squez(ib)) + if (istop(ib) .eq. ntot) then + nnsk = nint((lenbar-tstart(ib))/space(ib)) + else + nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib)) + end if + elskb = elskb+elsperns*nnsk + if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then + call catspace(space(ib),squez(ib),nnsk) + else +c +c This is the first entry for this bar +c + nnpd(nptr(ibarcnt)) = nnsk + durb(nptr(ibarcnt)) = space(ib) + sqzb(nptr(ibarcnt)) = squez(ib) + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + end if +c +c Update minimum space spanned by a note +c + if (abs(squez(ib)-1) .lt. tol) + * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib)) + if (istop(ib) .eq. ntot) go to 15 +c +c End of spatial accounting for now +c + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space for new block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue +c nb = ib +c +c Debug writes +c +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c + return + end + subroutine midievent(typeq,in1,in2) +c +c We now store "conductor" events in mmidi(numchan,.), and count bytes +c with imidi(numchan) +c + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comevent/ miditime,lasttime + character*1 typeq + idur = isetvarlen(miditime-lasttime,nbytes) + imidi(numchan) = imidi(numchan)+nbytes+1 + do 1 i = 1 , nbytes + mmidi(numchan,imidi(numchan)-i) = mod(idur,256) + idur = ishft(idur,-8) +1 continue + mmidi(numchan,imidi(numchan)) = 255 + if (typeq .eq. 't') then +c +c Tempo event. in1 = quarters per minute (integer) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+1 + mmidi(numchan,imidi(numchan)+2) = 3 + misperq = nint(60000000./in1) + do 2 i = 1 , 3 + mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256) + misperq = ishft(misperq,-8) +2 continue + imidi(numchan) = imidi(numchan)+5 + else if (typeq .eq. 'm') then +c +c Meter event. in1=numerator, in2=denom (power of 2) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+8 + mmidi(numchan,imidi(numchan)+2) = 4 + mmidi(numchan,imidi(numchan)+3) = in1 + if (in2 .gt. 0) then + mmidi(numchan,imidi(numchan)+4) = log2(in2) + else + mmidi(numchan,imidi(numchan)+4) = 0 + end if + mmidi(numchan,imidi(numchan)+5) = 24 + mmidi(numchan,imidi(numchan)+6) = 8 + imidi(numchan) = imidi(numchan)+6 + else if (typeq .eq. 'k') then +c +c Keychange event. in1 = isig +c + mmidi(numchan,imidi(numchan)+1) = 5*16+9 + mmidi(numchan,imidi(numchan)+2) = 2 + mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256) + mmidi(numchan,imidi(numchan)+4) = 0 + imidi(numchan) = imidi(numchan)+4 + else + print*,'Program flameout in midievent' + call stop1() + end if + lasttime = miditime + return + end + subroutine moveln(iuin,iuout,done) + logical done + character*129 outq + done = .false. + read(iuin,'(a)',end=1) outq + lenout = llen(outq,129) + write(iuout,'(a)') outq(1:lenout) + return +1 done = .true. + return + end + subroutine mrec1(lineq,iccount,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + function ncmid(iv,ip) + parameter (nm=24) + common /all/ mult(nm,200),jv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + if (ncc(iv) .eq. 1) then + ncmid = ncmidcc(iv,1) + else + xtime = to(ipl2(ivx,ip)) + do 1 icc = ncc(iv) , 1 , -1 + if (xtime .gt. tcc(iv,icc)-tol) then + ncmid = ncmidcc(iv,icc) + return + end if +1 continue + print*,'Problem in ncmid()' + stop + end if + end + function ncmidf(clefq) +c +c Return middle line of a clef +c + character*1 clefq +c if (clefq.eq.'t' .or. clefq.eq.'0') then +c ncmidf = 35 +c else if (clefq.eq.'s' .or. clefq.eq.'1') then +c ncmidf = 33 +c else if (clefq.eq.'m' .or. clefq.eq.'2') then +c ncmidf = 31 +c else if (clefq.eq.'a' .or. clefq.eq.'3') then +c ncmidf = 29 +c else if (clefq.eq.'n' .or. clefq.eq.'4') then +c ncmidf = 27 +c else if (clefq.eq.'r' .or. clefq.eq.'5') then +c ncmidf = 25 +c else if (clefq.eq.'f' .or. clefq.eq.'7') then +c ncmidf = 37 +c else +c ncmidf = 23 +c end if + ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 + return + end + subroutine newvoice(jv,clefq,change) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + character*1 ulfbq,clefq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical change,autofbon + nvmx(jv) = 1 + ivmx(jv,1) = jv + itsofar(jv) = 0 + nnl(jv) = 0 + nfb(jv) = 0 + if (firstgulp .or. change) then + ncmidcc(jv,1) = ncmidf(clefq) + else + ncmidcc(jv,1) = ncmidcc(jv,ncc(jv)) + end if + tcc(jv,1) = 0. + ncc(jv) = 1 + nudoff(jv) = 0 + ndotmv(jv) = 0 + do 5 j = 1 , 200 + irest(jv,j) = 0 + islur(jv,j) = 0 + ipl(jv,j) = 0 + nacc(jv,j) = 0 + iornq(jv,j) = 0 + mult(jv,j) = 0 + if (jv.le.2) isfig(jv,j) = .false. +5 continue + return + end + subroutine notefq(noteq,lnote,nolev,ncmid) +c +c Returns name of note level with octave transpositions, updates noctup. +c + common /comoct/ noctup + character*8 noteq + character*1 upcaseq,noteqt,chax + nupfroma = mod(nolev+1,7) + iname = 97+nupfroma + ioctup = (nolev+1)/7-4 + noteqt = chax(iname) + if (ncmid .eq. 23) noteqt = upcaseq(noteqt) + if (ioctup .eq. noctup) then + noteq = noteqt + lnote = 1 +c +c Must ALWAYS check if lnote=1 for use with functions requiring a blank +c + else if (ioctup .gt. noctup) then +c +c Raise octave. Encase in {} +c + write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1), + * noteqt,'}' + lnote = 3+ioctup-noctup + noctup = ioctup + else +c +c Lower octave +c + write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1), + * noteqt,'}' + lnote = 3+noctup-ioctup + noctup = ioctup + end if + return + end + subroutine notex(notexq,lnote) +c +c Returns non-beamed full note name +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig,ispoi,btest,even + character*1 udq,udqq,chax + character*4 dotq + character*2 numq + character*79 notexq + character*8 noteq + character*40 restq + common /compoi/ ispoi + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + nodu = nodur(ivx,ip) + if (.not.btest(irest(ivx,ip),0)) then + udq = udqq(nole,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) + end if +c +c Check figure level +c +c if (figbass .and. isfig(ivx,ip) +c * .and. .not.btest(irest(ivx,ip),0)) then + if (figbass .and. .not.btest(irest(ivx,ip),0) .and. + * ((ivx.eq.1.and.isfig(1,ip)) + * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then + if (udq .eq. 'u' .or. nodu.ge.64) then +c +c Upper or no stem, fnole (in noleunits) set by notehead +c + fnole = nole + else +c +c Lower stem, fnole set by bottom of stem +c + fnole = nole-stemlen + end if + zmin = fnole-ncmid(ivx,ip)+4 + if (ivx .eq. 1) then + ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin)) + else + ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin)) + end if + end if + if (.not.btest(irest(ivx,ip),0)) then + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + if (nodu .eq. 1) then + notexq =sq//'cccc'//udq//noteq(1:lnoten) + lnote = lnoten+6 + else if (nodu .eq. 2) then + notexq =sq//'ccc'//udq//noteq(1:lnoten) + lnote = lnoten+5 + else if (nodu .eq. 4) then + notexq =sq//'cc'//udq//noteq(1:lnoten) + lnote = lnoten+4 + else if (nodu .eq. 8) then + notexq =sq//'c'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 16) then + notexq =sq//'q'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 32) then + notexq =sq//'h'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 64) then + notexq =sq//'wh'//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 128) then +c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' +c lnote = lnoten+10 + notexq =sq//'breve'//noteq(1:lnoten) + lnote = lnoten+6 + else + dotq = 'p' + ldot = 1 + if (btest(iornq(ivx,ip),13)) then +c +c Dotted note with ')' ornament +c + dotq='m' + else if (btest(islur(ivx,ip),3)) then +c +c Double dot +c + dotq = 'pp' + ldot = 2 + end if + if (nodu .ge. 192) then + notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+6+ldot + else if (nodu .ge. 96) then + notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 48) then + notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 24) then + notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 12) then + notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 6) then + notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+4+ldot + ispoi = .true. + else + notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+5+ldot + ispoi = .true. + end if + if (dotq(1:1) .eq. 'm') then +c +c Need another call to the note, in case the first one has octave shifts +c + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + end if + else if (btest(islur(ivx,ip),29)) then +c +c Blank rest +c + notexq = sq//'sk' + lnote = 3 + else +c +c Non-blank rest +c + lnote = 0 + nole = mod(nole+20,100)-20 +c +c Kluge to get pause symbol for rp: +c + if (btest(islur(ivx,ip),19)) nodu = 64 + if (nodu .le. 28) then +c +c Normal rest < or = double-dotted quarter +c + lrest = 3 + if (nodu .gt. 14) then + restq =sq//'qp' + else if (nodu .gt. 7) then + restq =sq//'ds' + else if (nodu .gt. 3) then + restq =sq//'qs' + else if (nodu .gt. 1) then + restq =sq//'hs' + else + restq =sq//'qqs' + lrest = 4 + end if +c if (2**log2(nodu) .ne. nodu) then +cc +cc One or two dots on rest +cc +c restq = restq(1:3)//'p' +c lrest = 4 +c if (2*nodu .gt. 3*2**log2(nodu)) then +cc +cc Double dotted rest +cc +c restq = restq(1:4)//'p' +c lrest = 5 +c end if +c end if + notexq = restq + lnote = lrest +c +c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. +c + if (nole .ne. 0) then + if (abs(nole) .lt. 10) then + noteq = chax(48+abs(nole)) + lnoten = 1 + else + write(noteq(1:2),'(i2)')abs(nole) + lnoten = 2 + end if + if (nole .gt. 0) then + notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' + else + notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' + end if + lnote = 16+lnoten +c if (2**log2(nodu) .ne. nodu) then +cc +cc Have dot in raised rest. must put in hbox! +cc +c notexq = notexq(1:lnote)//sq//'hbox{' +c lnote = lnote+6 +c end if + notexq = notexq(1:lnote)//restq(1:lrest) + lnote = lnote+lrest +c if (2**log2(nodu) .ne. nodu) then +c notexq = notexq(1:lnote)//'}' +c lnote = lnote+1 +c end if + end if + if (2**log2(nodu) .ne. nodu) then +c +c Deal with dots (on rests shorter than half rest) +c + restq = sq//'pt' + lrest = 3 + if (2*nodu .gt. 3*2**log2(nodu)) then + restq = sq//'ppt' + lrest = 4 + end if + nole = nole+4 + raisedot = 0 +c +c Tweak dot positions for special cases +c + even = (mod(100+nole,2).eq.0) +c if (.not.even.and.nodu.gt.8.and. +c * (nole.lt.0.or.nole.gt.8)) then + if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then + raisedot = 1 + end if + if (nole.ge.10 .or. nole.le.-1) then + write(numq,'(i2)')nole + restq = restq(1:lrest)//'{'//numq//'}' + lrest = lrest+4 + else + restq = restq(1:lrest)//chax(nole+48) + lrest = lrest+1 + end if + if (raisedot.gt.0) then + restq = sq//'raise'//sq//'internote'// + * sq//'hbox{'//restq(1:lrest)//'}' + lrest = lrest+23 + end if + + + + notexq = restq(1:lrest)//notexq(1:lnote) + lnote = lnote+lrest + end if + else +c +c Half rest or longer +c + if (nole .eq. 0) then +c +c Half or longer rest is not raised or lowered +c + if (nodu .le. 56) then + notexq =sq//'hpause' + lnote = 7 + else if (nodu .le. 112) then + if (.not.btest(islur(ivx,ip),19) .or. + * btest(irest(ivx,ip),25)) then + notexq = sq//'pause' + else + notexq = sq//'pausc' + end if + lnote = 6 + else + notexq =sq//'PAuse' + lnote = 6 + end if + if (2**log2(nodu) .ne. nodu) then +c +c Dotted rest, hpause or longer +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + if (2*nodu .gt. 3*2**log2(nodu)) then +c +c Double dotted long rest +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if + end if + else +c +c Raised or lowered half or whole rest +c + if (nodu .eq. 32) then + notexq = sq//'lifthpause' + lnote = 11 + else if (nodu .eq. 48) then + notexq = sq//'lifthpausep' + lnote = 12 + else if (nodu .eq. 56) then + notexq = sq//'lifthpausepp' + lnote = 13 + else if (nodu .eq. 64) then + notexq = sq//'liftpause' + lnote = 10 + else if (nodu .eq. 96) then + notexq = sq//'liftpausep' + lnote = 11 + else if (nodu .eq. 112) then + notexq = sq//'liftpausepp' + lnote = 12 + else if (nodu .eq. 128) then + notexq = sq//'liftPAuse' + lnote = 10 + else +c +c Assume dotted double whole rest +c + notexq = sq//'liftPAusep' + lnote = 11 + end if +c +c Set up height spec +c + nole = sign(abs(nole)/2,nole) + if (nole.le.9 .and. nole.ge.0) then + noteq = chax(48+nole) + lnoten = 1 + else + noteq = '{' + if (nole .ge. -9) then + write(noteq(2:3),'(i2)')nole + lnoten = 3 + else + write(noteq(2:4),'(i3)')nole + lnoten = 4 + end if + noteq = noteq(1:lnoten)//'}' + lnoten = lnoten+1 + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + end if + end if + return + end + function ntindex(line,s2q,lenline) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q,line + character*1 chax + logical intex + ndxs2 = index(line,s2q) + ndxbs = index(line,chax(92)) + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(line,lenline) + intex = .true. + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(line(ic+1:len),s2q)+ic + else + ntindex = ndxs2 + return + end if + else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then + intex = .false. + else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92)) + * then + intex = .true. + end if +1 continue + end if + return + end + subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote) +c +c This appends to notexq e.g. '\ibbbu1' +c + common /combbm/ isbbm + logical isbbm + character*79 notexq + character*1 char1q,ulqq,chax + character*4 tempq + if (n .ge. 5) isbbm = .true. + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//chax(92)//char1q + else + notexq = chax(92)//char1q + end if + lnote = lnote+2 + do 3 im = 1 , n + notexq = notexq(1:lnote)//'b' + lnote = lnote+1 +3 continue +c +c add the number, 0 if 12 +c +c 5/25/08 Allow >12 +c +c call istring(mod(iv,12),tempq,len) + if (iv .lt. 24) then + call istring(iv,tempq,len) + else if (iv .eq. 24) then + tempq(1:1) = '0' + len = 1 + else + call printl('Sorry, too man open beams') + call stop1() + end if + notexq = notexq(1:lnote)//ulqq//tempq(1:len) + lnote = lnote+1+len + return + end + function numclef(clefq) +c +c Returns the number to be used as argument of \setclef (for MusiXTeX only) + character*1 clefq +c if (ichar(clefq) .lt. 55) then + if (ichar(clefq) .le. 55) then + numclef = ichar(clefq)-48 + if (numclef .eq. 7) numclef = 9 + else + numclef = index('tsmanrbxxf',clefq)-1 + end if + return + end + subroutine outbar(i,jlast) + character*1 chax + nfmt = log10(i+.5)+2 + if (jlast+5+nfmt .lt. 80) then + write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = jlast+5+nfmt + else + write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = 5+nfmt + end if + return + end + subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize) +cccccccccccccccccccccccccccccccccccccccccccccccc +cc cc +cc Subroutine, combine with pmxb.for +cc +cccccccccccccccccccccccccccccccccccccccccccccccc +cc +cc Need to consider X spaces in xtuplets when getting poenom, and +cc maybe fbar? +cc mx06a +cc ID numbers for voices when number of voices is reduced. +cc +cc mx03a +cc account for new fracindent for new movements. +cc +cc Known changes since pmxa. Version 1.1b (see pmxb for longer list) +cc +cc Check ID codes for slurs. +cc Version 1.24 still does not have details for spacing/positioning +cc arpeggios if there are accidentals or shifted notes or crowded scores. +cc Fix problem in 1.22 with arpeggios across multi-line staves +cc Fix problem in 1.22 with flat key signatures +cc Read setup data as strings +cc Warning for octave designation plus +/- +cc Don't pause for volta warning, +cc Macros +cc Correct fsyst to account for transposition and key changes. +cc Check for nbars > nsyst +cc +ccccccccccccccccccccccccccccccccccc + parameter (nm=24,nkb=3999,nks=125,maxblks=4000) + logical loop,usefig,isfirst,optimize + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + integer nn(nm),nodur(nm,200),ivxo(600),ipo(600), + * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600) + character*128 lnholdq + character*44 basenameq + logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt, + * stickyS + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr, + * shifton,barend + common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml, + * nodur,lenbar,iccount,nbars,itsofar,nib,nn, + * rest,lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + common /comeon/ eonk,ewmxk + logical mrecord,mplay,endmac,gotclef,cstuplet + logical novshrinktop,upslur,fontslur,WrotePsslurDefaults + common /comnvst/ novshrinktop,cstuplte + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + data wtimesig,wclef,wkeysig + * / 0.72 , 0.8 , 0.28 / + whead20 = 0.3 + if (.not.optimize) then + print* + print*,'Starting first PMX pass' + write(15,'(a)') ' Starting first PMX pass' + end if + if (isfirst) then + open(19,file='pmxaerr.dat') + write(19,'(i6)') 0 + close(19) + end if + if (.not.optimize) jprntb = 81 + macuse = 0 + ornrpt = .false. + stickyS = .false. + mrecord = .false. + mplay = .false. + lastchar = .false. + novshrinktop = .false. + cstuplet = .false. + fontslur = .true. + isligfont = .false. + fulltrans = .false. + do 42 ibarcnt = 1 , nkb + udsp(ibarcnt) = 0. + wminnh(ibarcnt) = -1. +42 continue +c +c Initialize input buffer +c + lenbuf0 = ipbuf + ipbuf = 0 + ilbuf = 1 + call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb) +c +c Set up list of instrument numbers (iv) +c + ivnow = 0 + do 13 instnow = 1 , noinst + do 14 iscount = 1 , nsperi(instnow) + ivnow = ivnow+1 + instno(ivnow) = instnow +14 continue +13 continue +c +c Save initial meter for midi +c + if (.not.isfirst .and. npages.eq.0) then + print*,'Sorry, must have npages>0 for optimization.' + call stop1() + end if + nsyout = nsyst +c +c isig1 will be changed in getnote if there is a transposition +c + isig1 = newkey(1) + if (npages .gt. nsyst) then + call printl('npages > nsyst in input. Please fix the input.') + call stop1() + end if +c +c fbar = afterruleskip/elemskip +c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt +c + fbar = 1. + wheadpt = whead20*musize + ifig = 0 + usefig = .true. + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbr1 = lenmult*mtrnuml*lenbeat + lenbr0 = nint(lenmult*xmtrnum0*lenbeat) + mtrnuml = 0 + if (lenbr0 .ne. 0) then + ibaroff = 1 + lenbar = lenbr0 + else + ibaroff = 0 + lenbar = lenbr1 + end if + ibarcnt = 0 + nptr(1) = 1 + iccount = 128 + nmovbrk = 0 + nflb = 0 + nfpb = 0 + ipagfpb(0) = 1 + isysfpb(0) = 1 + ibarflb(0) = 1 + isysflb(0) = 1 + nistaff(0) = nv-1 +c +c Check for pmx.mod +c + linesinpmxmod = 0 +c line1pmxmod = ilbuf + call getpmxmod(.true.,' ') + if (.not.isfirst .and. linesinpmxmod .gt. 0) then + print*,'Sorry, cannot optimize if there is a pmx.mod file' + call stop1() + end if +c +c Initialize for loop over lines +c + nkeys = 1 + ibrkch(1) = 1 + mbrestsav = 0 + shifton = .false. + firstline = .true. + newmeter = .false. + ihead = 0 + isheadr = .false. + gotclef = .false. + idsig = 0 + iddot = 0 + fintstf = -1. + gintstf = 1.0 + listcresc = 0 + listdecresc = 0 +30 loop = .true. + iskchb = .false. + issegno = .false. + nbars = 0 + ibarmbr = 0 +3 do 4 iv = 1 , nv + nvmx(iv) = 1 + ivmx(iv,1) = iv + itsofar(iv) = 0 + nnl(iv) = 0 + do 5 j = 1 , 200 + rest(iv,j) = .false. + nacc(iv,j) = 0. +5 continue +4 continue + iv = 1 + ivx = 1 + fbon = .false. + barend = .false. + isvolt = .false. +2 if (loop) then +c +c Within this short loop, nv voices are filled up for the duration of a block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nodur(..),rest(..). nnl will later be +c increased and things slid around as accidental skips are added. +c + call g1etnote(loop,ifig,optimize,fulltrans) + if (lastchar) go to 20 + go to 2 + end if + if (mbrestsav .gt. 0) then + call printl(' ') + call printl( + * 'You must enter the same multibar rest in ALL parts') + call stop1() + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 +c +c The following is just a signal to start a new bar when cataloging spaces +c for catspace(...) +c + nptr(ibarcnt+1) = nptr(ibarcnt) + newmb(ibarcnt) = .false. + if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true. +c +c Above is only for spacing calcs later on. Remember new meter can only occur +c at START of a new input line (ibar = 1) +c + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb) + else + if (.not.optimize) then + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + jprntb = 0 + end if + ibaroff = ibaroff-mbrest+1 + end if + if (firstline .and. lenbr0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenbr0 + else + lenbar = lenbr1 + end if + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nodur(ivx,ip) = nodur(ivx,ip+ioff) + rest(ivx,ip) = rest(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) +12 continue +11 continue + end if + do 67 iv = 1 , nv + do 67 kv = 1 , nvmx(iv) + ioff= 0 + if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1) +67 continue + call makeabar() + elsk(ibarcnt) = elskb+fbar +10 continue + newmeter = .false. + firstline = .false. + go to 30 +20 continue +c +c Vertical analysis. +c + if (npages .eq. 0) then + if (nsyst .eq. 0) then + print*,'When npages=0, must set nsyst=bars/syst, not 0' + call stop1() + end if + nsyst = (ibarcnt-1)/nsyst+1 + if (nv .eq. 1) then + nsystpp = 12 + else if (nv .eq. 2) then + nsystpp = 7 + else if (nv .eq. 3) then + nsystpp = 5 + else if (nv .eq. 4) then + nsystpp = 3 + else if (nv .le. 7) then + nsystpp = 2 + else + nsystpp = 1 + end if + npages = (nsyst-1)/nsystpp+1 + end if +c +c Check nsyst vs ibarcnt +c + if (nsyst .gt. ibarcnt) then + print* + print*,'nsyst,ibarcnt:',nsyst,ibarcnt + print*,'There are more systems than bars.' + write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt + write(15,'(a)')' There are more systems than bars.' + call stop1() + end if +c +c Set up dummy forced line & page breaks after last real one +c + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+1 + isysflb(nflb) = nsyst+1 + nfpb = nfpb+1 + ipagfpb(nfpb) = npages+1 + isysfpb(nfpb) = nsyst+1 + heightil = ptheight*4./musize + open(12,status='SCRATCH') + write(12,'(a)')basenameq(1:lbase) + write(12,*)lbase +c +c Pass to pmxb the initial signature, including effect of transposition. +c + write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait, + * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1 + write(12,*)npages,widthpt,ptheight,hoffpt,voffpt,nsyst + iflbnow = -1 + isysb4 = 0 + do 8 ifpb = 1 , nfpb +c +c Each time thru this loop is like a single score with several pages +c + npages = ipagfpb(ifpb)-ipagfpb(ifpb-1) + nsyst = isysfpb(ifpb)-isysfpb(ifpb-1) + nomnsystp = (nsyst-1)/npages+1 + nshort = nomnsystp*npages-nsyst + do 7 ipage = 1 , npages + nsystp = nomnsystp + if (ipage .le. nshort) nsystp = nsystp-1 +c +c Last system number on this page: + isysendpg = isysb4+nsystp + nintpg = 0 + do 15 isy = isysb4+1, isysendpg + if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1 + nintpg = nintpg+nistaff(iflbnow) +15 continue + xilfrac = 0. + xiltxt = 0. + if (ipage.eq.1 .and. ihead.gt.0) then +c +c Needn't zero out ihead after printing titles if we only allow titles at top? +c + if (iand(ihead,1) .eq. 1) then + xiltxt = xiltxt+hgtin*4/musize + xilfrac = xilfrac+etait + end if + if (iand(ihead,2) .eq. 2) then + xiltxt = xiltxt+hgtti*4/musize + xilfrac = xilfrac+etatc + end if + if (iand(ihead,4) .eq. 4) then + xiltxt = xiltxt+hgtco*4/musize + xilfrac = xilfrac+etacs1 + else +c +c Use double the title-composer space if there is no composer +c + xilfrac = xilfrac+etatc + end if + end if + D = xilfrac+nsystp-1+etatop+etabot +c C = nsystp*(nv-1) + C = nintpg +c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn + xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn + if (bottreb) xN = xN-(nsystp-1)*xilbtc + if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr + if (ifig .eq. 1) then + xN = xN - nsystp*xilfig + end if + glueil = (xN-b*C)/(D+a*C) + omegaG = (b*D+a*xN)/(D+a*C) +c +c G = \interlines between systems +c omega*G = \interlines between staves of the same system +c \interstaff = 4+omega*G +c C = total number of interstaff spaces in the page +c D = omega-indep factors for scalable height = nsy-1 (intersystem glue) +c + etatop + etabot + etatxt + +c N = scaleable height (\interlignes) = height - htext - staff heights - xil +c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles +c + (nsy-1)*xiltcb for treble clef bottoms +c + nsy*xilfig for figures +c G = N/(D + omega * C) = glueil, (1) +c But (empirically) omega*G = a*G + b (2) +c with a=1.071 and b=2.714 +c Solving (1) and (2) gives +c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) +c Pass to pmxb omega*G (=\interstaff-4) +c (etatop,bot,it,tc,cx)*G as inputs to \titles +c +c glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) +c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) +c xnsttop = glueil*etatop +c xintstaff = 4+gfact*glueil +c +c Only the first page will get local adjustment now if needed, others in pmxb +c + if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then + facins = fintstf + fintstf = -1. + else +c +c gintstf = 1.0 by default, but may be changed with AI +c + facins = gintstf + end if + write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4) + ihead = 0 + isheadr = .false. + isysb4 = isysendpg +7 continue +8 continue +c +c Done with vertical, now do horizontals +c + celsk(1) = elsk(1) + do 21 ibar = 2 , ibarcnt + celsk(ibar) = celsk(ibar-1)+elsk(ibar) +21 continue + lastbar(0) = 0 + ibar1 = 1 + wmins = -1. + iflb = 1 + imovbrk = 0 + ikey = 1 +c +c Return nsyst to its *total* value +c + nsyst = isysfpb(nfpb)-1 + do 22 isyst = 1 , nsyst + if (isyst .eq. isysflb(iflb)) iflb = iflb+1 + if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then + if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1 + end if + ibarb4 = lastbar(isyst-1) + if (isyst .eq. 1) then + if (isfirst) elsstarg = celsk(ibarflb(1)-1)/ + * (isysflb(1)-1-fracindent)*(1-fracindent) + celskb4 = 0. + else + celskb4 = celsk(ibarb4) +c +c Must dimension isysmb(0:*) just so I can execute this test! +c + if (isfirst) then + if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then +c +c First syst after forced line break. There may be indentation. +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst-fracsys(imovbrk)) + * *(1-fracsys(imovbrk)) + else +c +c There is no indentation to deal with +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst) + end if + end if + end if + if (isfirst) then + diff1 = abs(elsstarg-elsk(ibarb4+1)) + do 23 ibar = ibarb4+2 , ibarcnt + diff = elsstarg-(celsk(ibar)-celskb4) + if (abs(diff) .ge. diff1) go to 24 + diff1 = abs(diff) +23 continue +24 ibar = ibar-1 + lastbar(isyst) = ibar + nbarss(isyst) = ibar-ibarb4 + else +c +c nbarss is given as an input, must compute lastbar and ibar +c + lastbar(isyst) = nbarss(isyst)+ibarb4 + ibar = lastbar(isyst) + end if +c +c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. +c + elss(isyst) = celsk(ibar)-celskb4 + write(12,'(i5)')lastbar(isyst-1)+1 +c +c Transposed sigs are isig1, newkey(2,3,...). +c + if (ikey .eq. 1) then + key1 = isig1 + else + key1 = newkey(ikey) + end if + fsyst = wclef+abs(key1)*wkeysig+2./musize + xelsk = 0. +1 if (ikey.lt.nkeys) then + if (ibrkch(ikey+1).le.lastbar(isyst)) then +c +c Add space for all key changes +c + ikey = ikey+1 + key2 = newkey(ikey) + naccs = max(abs(key2-key1),max(abs(key1),abs(key2))) + fsyst = fsyst+naccs*wkeysig +c +c Account for afterruleskips (fbar) +c + xelsk = xelsk+fbar/2 + if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey)) + * xelsk = xelsk-1. + key1 = key2 + go to 1 + end if + end if +c +c Add extra fixed space for double bar +c + if (isyst .eq. nsyst) then + fsyst = fsyst+4.5/musize + end if +c +c Add extra fixed space for initial time signature +c + if (isyst .eq. 1) then + fsyst = fsyst+wtimesig + end if +c +c Add extra fixed space for time signature changes & user-defined spaces +c + do 26 ibars = ibarb4+1 , lastbar(isyst) + if (newmb(ibars)) fsyst = fsyst+wtimesig + fsyst = fsyst+udsp(ibars)/musize +26 continue + if (isyst .eq. 1) then + wdpt = widthpt*(1-fracindent) + else + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + wdpt = widthpt*(1-fracsys(imovbrk)) + else + wdpt = widthpt + end if + end if + wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst) +c +c Checks for min spacing +c Get min allowable space +c + dtmin = 1000. + do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1 + dtmin = min(dtmin,tnminb(ibar)) + if (wminnh(ibar).ge.0.) wmins = wminnh(ibar) +45 continue + if (wmins .lt. 0) wmins = 0.3 + wminpt = (1+wmins)*0.3*musize +c +c Find max duration & # of notes for this system +c + dtmax = 0. + nns = 0 + do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + dtmax = max(dtmax,durb(iptr)) + nns = nns + nnpd(iptr) +43 continue + elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk) + if (elmin0 .ge. wminpt) then +c +c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; +c there is no need to "flatten" +c + sumelsk = elss(isyst)-fbar*nbarss(isyst) + eonk = 0. + ewmxk = 1. + else + elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns) + if (elmin1 .le. wminpt) then +c print* +c print*,'In system #',isyst,' cannot meet min. space rqmt' +c write(15,'(/a,i5,a)') +c * 'In system #',isyst,' cannot meet min. space rqmt' + eonk = 0.9 + else +c +c Find eonk by Newton method +c +c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) + call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1, + * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax, + * (wminpt-elmin0)/(elmin1-elmin0)) + eonk = min(.9,eonk) + end if + ewmxk = f1eon(dtmax)**eonk +c +c Recompute poenom! +c + sumelsk = 0 + do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + sumelsk = sumelsk + * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr)) +44 continue + end if + poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk) +c +c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 +c + if (isyst .gt. 0) then + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + fracindent = fracsys(imovbrk) + else + fracindent = 0. + end if + end if + write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst), + * sumelsk,fsyst,fracindent,eonk,ewmxk + ibar1 = ibar1+nbarss(isyst) +22 continue + rewind(12) + open(13,status='SCRATCH') + write(13,'(i5)')ifig + rewind(13) + ilbuf = 1 + ipbuf = 0 + if (.not.optimize) then + write(*,'(/,a)')' Done with first pass' + print* + write(15,'(/,a)')' Done with first pass' + write(15,'()') + end if +c +c Following syntax is needed since pmxa is called with literal argument .false. +c + if (isfirst) isfirst = .false. + return + end + subroutine pmxb(inlast,poevec,ncalls,optimize) +cccccccccccccccccccccccccc +cc +cc To Do +cc +cc Resolve disagreement in final poe for 1st system, compared with *.mx2 +cc Shift slurs on right- or left-shifted main notes (2/7/99) +cc Various end-of-input-block repeat problems (ick142.pmx). +cc Force multiplicity for un-beamed xtups. +cc Clef change at end of piece +cc Global "A" option to maximize "X" at a given time tick. +cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted +cc note. See trubl18.pmx +cc Tab character as space. +cc Clef interference with second line of music. +cc Add space for interferences between *different* lines of music? +cc Shift arpeggios, both automatic and manual. +cc Different musicsize for different instruments. +cc Spacing checks for accid's on left-shifted chord notes +cc Spacing checks for double dots +cc Allow forced line breaks w/o setting nsyst. +cc Cresc-Decresc. (Enhance MusiXTeX first?) +cc Dynamic Marks. +cc Bug with Voltas at line end (MusiXTeX problem?). +cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx +cc Stem-end slurs. +cc Allow units in indentation. +cc Make inline TeX more context sensitive. +cc Werner's 4/2/98 problem with "o?" +cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. +cc converts e.g. "r2db" into "r2d", which might be wrong. +cc Werner's generalsignature problem with Key change and new transposition. +cc (wibug8.pmx) +cc Unequal xtuplets +cc Print both sets of bar #'s in tex file. +cc Make barlines invisible \def\xbar{\empty} , fix fbar. +cc Auto-tie slurs 'At' +cc Forced line break anywhere (e.g. at a mid-bar repeat). +cc Clef change at very start of file. +cc Tighten test for M as macro terminator. +cc Fix title so not separate limit on author length + composer length. +cc Arpeggios in xtups. +cc +cc mx10b +cc Option for instrument name at top center. Last item in P command: +cc P[n]c text is instrument name (use in parts) +cc P[n]cstuff text is stuff (up to 1st blank) +cc P[n]c"stuff with spaces" text is stuff with spaces +cc +cc Post version 1.43 +cc Reduced space rqmt for multiplicity-0 graces (no flag) +cc Removed last sepsym in centered whole-bar rests, fixes volta height bug. +cc +cc Version 1.43 +cc Fix spacing for end-of-line signature change. +cc Adjust left-shift of grace group for shifted accidentals. +cc Put in extra space for left-shifted accidentals. +cc Fix bug with dot-shift before accid-shift on chord note. +cc Space-check for right-shifted main notes. +cc Enable forcing stem direction of single notes in non-beamed xtups. +cc Disallow clef change after last note before end of input block (pmxa) +cc Print meter change before page break +cc increase length of strings for \titles macro +cc version 1.42 +cc Loosen up input syntax for "X" commands. Subroutine getx() +cc "B" and "P" in "X" commands +cc mx09b +cc Allow multiple rests at start of xtup +cc Add 64th rest +cc Fix xtup numbers over rests. (subroutine levrn) +cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. +cc c za / ( c a ... +cc Allow double dots to be shifted. +cc Fix spacing with double dotted notes; permit splitting small note. +cc Fix \dotted printout so it works with old compiler +cc mx08b +cc Automatic spaces if needed for shifted accidentals. +cc Some Dynamics +cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) +cc version 1.41 +cc Allow ":" as last char of path name +cc Dotted slurs "sb" +cc Continue bar numbering at movement break "L[integer]Mc" +cc mx07b +cc Whole-bar rests with double lines of music. Fixed all options ? +cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. +cc Option to suppress centering full-bar rests. "o" +cc mx06b +cc Shift accid on left-shifted chord note. +cc Rest as first note of xtup. +cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt +cc Allow Rb for single bar at movemnet break or end of piece. (islur(25)) +cc Change # of inst at a movement break. noinst is total # and must be used +cc in 1st movement. ninow is current. nspern(1,...,ninow) is current +cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to +cc reprint names in parindent at a movement break. Default is .false. +cc unless ninow changes, then .true. But can force either with r+/- as +cc option in 'M' +cc mx04b +cc Double-dotted notes, separate+beamed, main+chord, still no extra space. +cc ??? Don't shift slur ends on whole notes. +cc (pmxa) Write line number of error in pmxaerr.dat +cc mx02b +cc Admit "RD" before "/" (search for "rptfq2:" ) +cc In doslur, for multi-line staves, single notes, check forced stem dir'n +cc before setting stemup (used to set horiz offset). +ccccccccccccccccccccccccccccccc + parameter (nm=24,nks=125,mv=24576,maxblks=4000) +c +c FYI /all/ differs in appearance in function ncmid +c + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) +ccccccccccccc +cc islur cc +ccccccccccccc +c bit meaning +c 0 slur activity on this note +c 1 t-slur here. +c 2 force 0-slope beam starting on this note +c 3 Double dotted note! +c 4 grace before main note +c 5 left repeat +c 6 right repeat +c 7 start Volta +c 8 doublebar +c 9 end Volta +c 10 on=>endvoltabox +c 11 on=>clefchange +c 12-14 0=>treble, ... , 6=>bass +c 15 on=> start new block for clef change (maybe diff. voice) +c 16 literal TeX string +c 17 1=up, 0=down stem for single note (override) See bit 30! +c 18 if on, prohibit beaming +c 19 if on, full bar rest as pause +c 20 Beam multiplicity down-up +c 21 Forced multiplicity for any beam including xtups +c 22-24 Value of forced multiplicity +c 25 single barline at movement break +c 26 doubleBAR (see bits 5,6,8) +c 27-28 Forced beam fine-tune height (1 to 3) +c 29 Blank rest +c 30 If on, get stem dir'n from bit 17 +c 31 If on, suppress printing number with xtuplet starting here +ccccccccccccc +cc ipl cc +ccccccccccccc +cc 0-7 Location in list [0,200] +c 0-7 Unused +c 8 left offset main note one headwidth +c 9 right offset main note one headwidth +c 10 chord present? +c 11-16 Forced beam height adjustment (-30 to +30) +c 17-22 Forced beam slope adjustment (-30 to +30) +c 23-26 Slur index for Way-after grace. Inserted when slur is started. +cc 27 Unused? +c 27 5th bit for slur index for Way-after grace (100712) +c 28 key change: only in voice 1 +c 29 Grace after main note. (Type A) +c 30 In forced beam. Signals need to check beam heights +c 31 Grace way after main note. (stretch to next note, type W) +ccccccccccccc +cc iornq cc +ccccccccccccc +c 0 Ornament "(". Was user-defined horizontal slur shift on this note +c until 9/24/97; changed that to irest(21) +c 1-13 stmgx+Tupf._) +c 14 Down fermata, was F +c 15 Trill w/o "tr", was U +c 16-18 Editorial s,f,n +c 19-20 >^ +c 21 "?" for editorial accid, w/ or w/o s,f,n +c 22 Set if ihornb governs ornament height. Same in icrdorn. +c 23 Set in getorn if ANY note at time of this main note has ornament. +c This is ONLY used in beamstrt to signal whether to do more +c tests for whether ihornb is needed. (ihornb is only needed +c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) +c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. +c 24 Slur on after or way-after grace. Use as signal to START slur. +c 25 Tweak orn ht. Same in icrdorn for chord note +c 26 Insert user-defined space before this note (was 22) +c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord +c 28 caesura or breath +c 29 blank barline (must be iv=1) (would have used islur but no room) +c 30 "Look-left" option for keyboard rest +c 31 Set if any note (main or chord) has cautionary accid, for space checks +ccccccccccccc +cc irest cc +ccccccccccccc +c 0 rest=1, no rest = 0 +c 1 There will be a vertical shift for number of this xtup +c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' +c 7 There is a horizontal shift for xtup number +c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 +c 14 Flip up/down-ness of xtup number +c 15 Single-voice, single note shift X(...)[p]S +c 16 Start single-voice, multinote shift with this note X(...)[p]: +c 17 End single-voice, multinote shift after this note. Enter symbol +c after note. X: +c 18 User-defined hardspace after last note of bar, *after* this note. +c Value still stored in udoff(ivx,nudoff(ivx)), not with other +c hardspaces in udsp, to avoid confusion with time checks. +c 19 Move the dot. Data stored in ndotmv,updot,rtdot +c 20 Set if right-shifted main or chord note here. Use for space checks. +c 21 User-defined hardspace in xtup +c 22 User-defined slur shift horizontal slur shift. +c 23 Set on last note before staff-jumping a beam. +c 24 Set on first note after staff-jumping a beam +c 25 Suppress rest centering. "ro" +c 26 Dynamic on this note +c 27 Set if left-shifted main or chord note here. Use for space checks. +c 28 Set if xtup starts on this note. +c 29 Set on lowest-voice note at same time as 1st note after jump-beam. +c 30 Set on note after end of jump-beam segment, to force new note group +c 31 Flag for cautionary accidental +ccccccccccccc +cc nacc cc +ccccccccccccc +c 0-1 0=no accid, 1=fl, 2=sh, 3=na +c 2 double +c 3 big +c 4-9 vertshift-32 +c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) +c 17 Midi-only accidental +c 18 2:1 xtup +c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. +c 20 Set on last note of each seg except last seg of single-slope beam. +c 21 Set on 1st note of each seg except 1st seg of single-slope beam. +c 22-26 If .ne.0, printed xtup number for xtup starting on this note. +c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase +c multiplicity by 1 +c 28 Set on main note of chord if accidentals are ordered. +c 29 Tag for chordal accidental shift...means add to autoshifts. +c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. +c If upstem|downstem, main is upper|lower member of 2nd +c Action is to interchange pitches only when notes are placed. +ccccccccccccc +cc mult cc +ccccccccccccc +c 0-3 Multiplicity+8 (mult= # of flags) +c 4 Set if slope adjustment for xtup bracket +c 5-9 16+slope adjustment +c 27 Stemlength override +c 28-30 New stem length. +ccccccccccccc +cc isdat1 cc +ccccccccccccc +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +ccccccccccccc +cc isdat2 cc +ccccccccccccc +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted slur +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +ccccccccccccc +cc isdat3 cc +ccccccccccccc +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +ccccccccccccc +cc isdat4 cc Set these all at turn-on using s option +ccccccccccccc +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +ccccccccccccc +c icrdat c +ccccccccccccc +c 0-7 ip within voice +c 8-11 ivx (together with 28th bit) +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Flag for cautionary accidental on chord note +ccccccccccccc +c icrdot c: +ccccccccccccc +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c +cccccccccccccccccccccccccccccccc + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk, + * isfig,rptnd1,rptprev + logical loop,lastchar,slint,svolta,evolta,onvolt, + * cwrest(nm),islast,inlast,optimize + integer istop(80),numbms(nm),istart(80) + real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks), + * tstart(80),squez(80) + character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq + character*79 notexq,inameq + character*40 pathnameq + character*44 basenameq + character*24 fmtq + character*20 voltxtq + character*120 instrq,titleq,compoq + common /comlast/ islast,usevshrink + logical usevshrink,stickyS,OptLineBreakTies,autofbon + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /comstart/ facmtr + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /combeam/ ibmtyp + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comas3/ ask(2500),iask,topmods + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2, + * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq,lnholdq + logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend, + * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb, + * btest,sluron,setis,nobar1 + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /compoi/ ispoi + common /combc/ bcspec + common /comeon/ eonk,ewmxk + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comhsp/ hpttot(176) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /commus/ musize,whead20 + common /comtol/ tol + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize, + * ismbr,putmbr + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comcb/ nbc,ibcdata(36) + common /comclefq/ clefq + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /combibarcnt/ ibarcnt + if (.not.optimize) then + print* + print*,'Starting second PMX pass' + print* + write(15,'(a)')'Starting second PMX pass' + end if + ncalls = ncalls+1 + islast = inlast + macuse = 0 + isyscnt = 0 + stemmax = 8.2 + stemmin = 3.9 + stemlen = 6.0 + sq = chax(92) + bcspec = .true. + topmods = .false. + ismbr = .false. + read(12,'(a)')basenameq + read(12,*)lbase + read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop, + * etabot,inbothd,inhnoh,isig + ilbuf = 1 + ipbuf = 0 + call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0, + * npages,nsyst,musicsize,fracindent,istype0,inameq, + * clefq,sepsymq,pathnameq,lpath,isig0) + if (ismidi) then +c +c Initial key signature and meter for pickup bar +c + call midievent('k',isig,0) + if (xmtrnum0 .gt. tol) then +c +c We have a pickup. Some tricky stuff to get a meter: +c + xntrial = xmtrnum0 + do 5 ip2 = 0 , 5 + if (abs(mod(xntrial,1.)) .lt. tol) go to 6 + xntrial = xntrial*2 +5 continue + print*,'Problem finding meter for pickup bar' + xntrial = 1. + ip2 = 0 +6 continue + call midievent('m',nint(xntrial),2**ip2*mtrdenl) + else +c +c No pickup, enter the starting meter +c + call midievent('m',mtrnuml,mtrdenl) + end if + end if +c +c Set musicsize from value passed in common, due to possible reset by S[n]m16 +c + musicsize = musize + read(12,*)npages,widthpt,height,hoffpt,voffpt,nsyst, + * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto +c +c If default width ever changes, must adjust this stmt. +c + slfac1 = 0.00569*524./widthpt + figbass = .false. + read(13,*)ifig + if (ifig .eq. 1) then + figbass = .true. + open(14,status='SCRATCH') + write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq// + * 'sysno by 1'//sq//'ifcase'//sq//'sysno%' + end if + lastchar = .false. + ibcoff = 0 + if (xmtrnum0 .gt. 0.) ibcoff = -1 + open(11,status='SCRATCH') +c +c vshrink for the first page is calculated in topfile, +c and if true set interstaff=10. vshrink affects Titles. +c Must also save vshrink for page ending. +c + call topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur) +c +c ninow is working value of # of instruments. noinst is max #, and # at start. +c + ninow = noinst +c +c Save original printed meter in case movement breaks +c + movnmp = mtrnmp + movdnp = mtrdnp +c + if (islast .and. figbass .and. musicsize.eq.16) + * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%' +c + if (islast .and. isligfont) then + if (musicsize .eq. 16) then + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%' + else + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%' + end if + end if + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenb1 = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenb1 = lenb1*2 + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + lenb0 = nint(xmtrnum0*lenbeat) + if (mtrdenl .eq. 2) lenb0 = lenb0*2 + if (lenb0 .ne. 0) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1' + lenbar = lenb0 + else + lenbar = lenb1 + end if +c +c Initialize full-program variables +c + fixednew = 0. + scaldold = 0. + fintstf = -1. + gintstf = 1. + nasksys = 0 + ibarcnt = 0 + iline = 0 + movbrk = 0 + isystpg = 0 + ipage = 1 + iccount = 128 + iask = 0 + nhstot = 0 + nb = 1 + if (.not.optimize) jprntb = 81 + idsig = 0 +c +c Next 5 are raise-barno parameters. irzbnd is integer part of default level. +c + irzbnd = 3 + if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4 + is1n1 = 0 + isnx = 0 + SlurCurve = 0. +c +c 111109 Made global rather than per gulp +c + ndyn = 0 + ispoi = .false. + slint = .false. + lrptpend = .false. + rptnd1 = .false. + rptfq2 = 'E' + rptprev = .false. + onvolt = .false. + flgndb = .false. + fbon = .false. + shifton = .false. + ornrpt = .false. + setis = .false. + lowdot = .false. + rename = .false. + nobar1 = .false. + equalize = .false. + usevshrink = .true. + WrotePsslurDefaults = .false. + OptLineBreakTies = .false. + HeaderSpecial = .false. +c +c vshrink is initialized in topfile +c + stickyS = .false. +c +c ixrest = 1 or 2 if xtup has started with a rest +c + do 1 ivx = 1 , nm + ixrest(ivx) = 0 + fullsize(ivx) = 1. +c +c Set legacy note level to middle c as default +c + ndlev(ivx,1) = 29 + ndlev(ivx,2) = 29 +1 continue + npreslur = 0 + nhssys = 0 + listslur = 0 + do 31 i = 1 , 202 + isdat1(i) = 0 + isdat2(i) = 0 +31 continue + nsdat = 0 +c +c Initialize flag for figures in any other voice than 1 +c + ivxfig2 = 0 +c +c Initialize for loop over gulps +c + firstgulp = .true. +c +c Start a gulp +c +30 loop = .true. + notcrd = .true. + isbjmp = .false. + isbj2 = .false. + autofbon = .false. + tautofb = 0. + nbars = 0 + nfigs(1) = 0 + nfigs(2) = 0 + ngrace = 0 + ntrill = 0 + ncrd = 0 + nudorn = 0 + nlit = 0 + nvolt = 0 + ibarmbr = 0 + nudsp = 0 +c ndyn = 0 ! 111109 + ntxtdyn = 0 + nbc = 0 + NumArpShift = 0 + do 3 i = 1 , 37 + graspace(i) = 0. +3 continue +c +c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. +c and also if nv increases in an 'M' directive. +c + do 4 iv = 1 , nv + call newvoice(iv,clefq(iv),.false.) +4 continue +c +c Check if endsymbol was set earlier +c + if (rptnd1) then + rptnd1 = .false. + rptfq2 = rptfq1 + else +c +c Only use if movbrk>0, to signal default ('RD') +c + rptfq2 = 'E' + end if + iv = 1 + ivx = 1 +2 if (loop) then +c +c Within this loop, nv voices are filled up for the duration of the block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). +c nbars is for this input block. +c Only at the beginning of an input block will there be a possible mtr change, +c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) +c + call getnote(loop) + if (lastchar) go to 40 + go to 2 + end if +c +c Finished an input block (gulp). +c + if (ismidi) then +c +c Put rests into midi array for 2nd lines that were not used in this gulp. +c + do 60 iv = 1 , nv + if (twoline(iv) .and. nvmx(iv).eq.1) then + if (firstgulp .and. lenb0.ne.0) then + call addmidi(midchan(iv,2),0,0,0, + * (nbars-1.)*lenbar+lenb0,.true.,.false.) + else + call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true., + * .false.) + end if + end if +60 continue + end if + nvolt = 0 + do 28 iv = 1 , nm + nudoff(iv) = 0 + ndotmv(iv) = 0 +28 continue +c +c Put stuff at top of p.1. Must wait until now to have read title info. +c + if (ibarcnt .eq. 0) then + call puttitle(inhnoh,xnsttop(ipage), + * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 + bar1syst = ibarcnt .eq. iauto + ndig = max(0,int(log10(.001+ibarcnt+ibcoff))) + if (islast) + * write(11,'(a11,i'//chax(50+ndig)//')') + * '% Bar count',ibarcnt+ibcoff + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb) + else + if (.not.optimize) then + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + jprntb = 0 + end if + ibcoff = ibcoff+mbrest-1 + if (ibar.eq.1 .and. firstgulp .and. + * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize +c +c The above may be he only case where the space-before option is used in \mbrest +c + end if +c +c Move the read to after end-of-bar hardspace checks, so we get right poenom +c at end of a line. +c if (bar1syst) read(12,*) poenom +c +c Check for clef at start of bar. No slide yet. Also flags at end of prev. +c bar. This block is run at the start of every bar. May fail for flag at +c end of last bar. To account for necc. hardspaces, compute and store +c nhssys = # of hard spaces for this system +c hesk(nhssys) = elemskips avialable +c hpts(nhssys) = hard points needed, including notehead +c Here, merely insert placeholder into output. Later, when poe is computed, +c compute additional pts and store them in hpttot(1...nhstot). Finally in +c subroutine askfig, write true pts where placeholders are. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(1,ibar-1) + clchb = btest(islur(1,ioff+1),15) + putmbr = .false. + if (ismbr) then + if (clchb) then +c +c Clef change and multi-bar rest coming up. Kluge to get space at end of rest. +c + write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest' + * //sq//'def'//sq//'mbrest#1#2#3{%' + write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55, + * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%' + end if + ismbr = .false. + putmbr = .true. + end if + if (ibar .eq. ibarmbr) ismbr = .true. +c +c Set flag here so at start of next bar, if there's a clef change, can add space +c after the mbr with the above kluge +c + if (.not.(clchb .or. flgndb)) go to 23 +c +c Must check available space +c + ptsndb = 0. +c +c Zero out block signal +c + if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15) +c +c In this loop, we determine how much hardspace is needed (if any) +c 9/7/97 Note that for last bar in input block, if number of lines of +c music decreases in new block, highest numbered ones won't be checked +c since the loop below covers the new nvmx(iv), not necessarily the old +c one. +c 4/18/98 Apparently nmxsav was a solution to the above problem +c + do 16 iv = 1 , nv + do 16 kv = 1 , nvmxsav(iv) + ivx = ivmxsav(iv,kv) + ptsndv = flgndv(ivx)*wheadpt + ioff = 0 + if (ibar .gt. 1) then + ioff = nib(ivx,ibar-1) + ip = ioff + if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2) +c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) + prevtn(ivx) = tnote(ipl2(ivx,ip)) +c +c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. +c + end if +c +c Only allow clef changes when ivx <= nv +c + if (ivx .le. nv) then + clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11) + if (clchv(iv)) then +c +c Clef change in this voice. Turn off signal. Get space avail. +c + islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11) + if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv = + * ptsndv+clefend*wheadpt + end if + end if + ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac) +16 continue +c +c ???? where is nb set??? nb probably in left over from makeabar +c + esk = feon(space(nb)*squez(nb)) + ptsdflt = esk*poenom-wheadpt +c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then + if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0 + * .and. .not.putmbr) then +c +c Must ADD hardspace! So put in a placeholder, and store params for later. +c + if (islast) write(11,'(a)')sq//'xardspace{ pt}%' + nhssys = nhssys+1 + if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then + hesk(nhssys) = esk + hpts(nhssys) = ptsndb+wheadpt + else + hesk(nhssys) = eskgnd + hpts(nhssys) = ptsgnd+wheadpt + end if + fixednew = fixednew+hpts(nhssys) + scaldold = scaldold+hesk(nhssys) + end if + if (clchb) then + do 17 iv = 1 , nv + if (clchv(iv)) then + notexq = sq//'znotes' + lnote = 7 + do 24 iiv = 2 , iv + notexq = notexq(1:lnote)//sepsymq(iiv-1) + lnote = lnote+1 +24 continue +c +c Recompute ioff since it will vary from voice to voice +c + if (ibar .eq. 1) then + ioff = 0 + else + ioff = nib(iv,ibar-1) + end if +c +c Must call clefsym to get nclef, even if there is a movement break +c + call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef) + if (movbrk.eq.0 .and. + * islast) + * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' + call wsclef(iv,ninow,clefq,nclef) + end if +17 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + end if +23 continue +c +c End of loop for end-of-bar hardspaces and non-movbrk clef symbol. +c + if (bar1syst) then + read(12,*) poenom + end if +c +c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) +c + if (ibar .eq. 1) then + islnow = islur(1,1) + iornqnow = iornq(1,1) + else + islnow = islur(1,nib(1,ibar-1)+1) + iornqnow = iornq(1,nib(1,ibar-1)+1) + end if +c +c Check for R-symbols set at end of prior input block +c + if (movbrk.eq.0 .and. rptfq2.ne.'E') then + if (rptfq2 .eq. 'D') then + islnow = ibset(islnow,26) + else if (rptfq2 .eq. 'r') then + islnow = ibset(islnow,6) + else if (rptfq2 .eq. 'd') then + islnow = ibset(islnow,8) + else if (rptfq2 .eq. 'b') then + islnow = ibset(islnow,25) + else + print* + print*,'Illegal symbol with "R" at end of input block:', + * rptfq2 + call stop1() + end if + rptfq2 = 'E' + end if + if (iand(islnow,352) .ne. 0) then +c +c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set +c + lrpt = btest(islnow,5) + rrpt = btest(islnow,6) + lrptpend = lrpt.and.bar1syst + if (lrpt .and. .not.lrptpend) then + if (rrpt) then + if (islast) write(11,'(a)')sq//'setleftrightrepeat' + fixednew = fixednew+wheadpt*lrrptfac-0.4 + else + if (islast) write(11,'(a)')sq//'setleftrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + end if + else if (rrpt) then + if (islast) write(11,'(a)')sq//'setrightrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + else if (btest(islnow,8)) then + if (islast) write(11,'(a)')sq//'setdoublebar' + fixednew = fixednew+wheadpt*dbarfac-0.4 + end if + else if (btest(islnow,26)) then +c +c doubleBAR +c + if (islast) write(11,'(a)')sq//'setdoubleBAR' + fixednew = fixednew+wheadpt*ddbarfac-0.4 + else if (btest(iornqnow,29)) then +c +c no bar line +c +c-- if (islast) write(11,'(a)')sq//'setzalaligne' +c++ + if (islast) then + if (movbrk .eq. 0) then + write(11,'(a)')sq//'setzalaligne' + else +c +c Encountered "Rz" at start of input block at start of new movement, Must +c use newmovement macro with arg 4 rather than setzalaligne, since former +c already redefines stoppiece. +c + rptfq2 = 'z' + end if + end if +c++ + fixednew = fixednew-0.4 + end if +c +c 1st and 2nd endings +c + svolta = btest(islnow,7) + evolta = btest(islnow,9) + if (evolta) then + if (btest(islnow,10)) then + if (islast) write(11,'(a)')sq//'endvoltabox' + else + if (islast) write(11,'(a)')sq//'endvolta' + end if + onvolt = .false. + end if + if (svolta) then + nvolt = nvolt+1 + lvoltxt = index(voltxtq(nvolt),' ')-1 + if (lvoltxt .eq. 1) then + if (islast) write(11,'(a)')sq//'Setvolta' + * //voltxtq(nvolt)(1:1)//'%' + else + if (islast) write(11,'(a)')sq//'Setvolta'//'{'// + * voltxtq(nvolt)(1:lvoltxt)//'}%' + end if + onvolt = .true. + end if + if (ibar .gt. 1) then + ipnow = nib(1,ibar-1)+1 + else + ipnow = 1 + end if + iplnow = ipl(1,ipnow) + if (bar1syst) then +c +c If listslur>0, then there is at least one slur or tie carried over the break +c + ispstie = .false. + if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0 + * .and. islast) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat, + * ispstie,sepsymq) + iline = iline+1 +c +c End an old system, Start a new system +c + if (iline .ne. 1) then +c +c Not first line. +c Get corrected poe = points/elemskip for *previous* system +c + wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + isyscnt = isyscnt+1 + poevec(isyscnt) = poe +c +c Transfer data for system into global arrays to hold until very end +c + do 9 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) +c +c Only admit negative ask if it was user-defined space, signalled by elask<=0. +c + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +9 continue + do 25 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +25 continue +c +c Reset counters for new system +c + scaldold = 0. + fixednew = 0. + nasksys = 0 + nhssys = 0 + end if +c +c End of if block for first bar of non-first system. Still 1st bar, any system +c + if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%' + isystpg = isystpg+1 +c +c Try moving the next stmt way down, to fix a bug and get \eject printed at +c end of single-system page. +c if (isystpg .eq. nsystp(ipage)) isystpg = 0 + read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk + if (iline .gt. 1) fracindent=frac + if (figbass) then + ifigdr(1,iline) = 4 + ifigdr(2,iline) = 4 + end if + slfac = slfac1*musicsize*elsktot + if (iline .ne. 1) then +c +c For the line just _finished_, put figdrop in separate file. +c + if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)') + * sq//'figdrop=',ifigdr(1,iline-1), + * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%' +c +c Check slurs in top staff for interference w/ barno. Only check when +c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS +c keep track of ons and offs when |isig|<=3. +c + ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1 + isnx = 0 + if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then +c +c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 +c Look for termination in remainder of this input block. If not found, +c just use is1n1. Remember, haven't slid down yet. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1) + do 50 isdat = 1 , nsdat + if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv)) + * .and. .not.btest(isdat1(isdat),11) + * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then +c +c Found slur ending. Just check note height, can't do fine adjustments. +c +c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) + is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19)) + go to 51 + end if +50 continue +c +c If exiting loop normally, did not find end of slur. c'est la vie. +c +51 continue + isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd) + if (isnx .gt. 0) then +c +c AHA! Slur likely to interfere with barno. +c +c Modified 090525 to use \bnrs +c + slint = .true. + fmtq = '(a16,i1,a14)' + if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)' + if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{', + * irzbnd+isnx,'.5'//sq//'internote}%' +c if (islast) then +c if (isnx .le. 9) then +c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' +c else +c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' +c end if +c end if +c + end if + end if + if (movbrk .gt. 0) then +c +c movbrk = 0 +c Move the reset down, so can use movbrk>0 to stop extra meter prints. +c +c New movement. Redefine stoppiece, contpiece. These will be called either +c explicitly or as part of alaligne. +c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. +c This is passed to \newmovement. +c + if (rptfq2 .eq. 'E') rptfq2 = 'D' + indsym = index('Ddrbz',rptfq2)-1 + rptfq2 = 'E' +c +c Also check for Rd or Rr set the normal way +c + if (btest(islnow,8)) then + indsym = 1 + else if (btest(islnow,6)) then + indsym = 2 + end if + if (indsym .lt. 0) then + print* + print*,'Illegal end symbol before "/"' + call stop1() + end if +c +c Check for continuation (no bar number reset) +c + if (islast.and. + * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1' + * //sq//'startbarno'//sq//'barno%' + 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 +c +c Change generalmeter if necessary +c + if (islast) call wgmeter(mtrnmp,mtrdnp) +c +c (Moved all name-writing to getnote, right when 'M' is detected) +c + if (btest(iplnow,28)) then +c +c Key signature at movement break +c + iplnow = ibclr(iplnow,28) + if (isig .gt. 0) then + if (islast) write(11,'(a18,i1,a2)') + * sq//'generalsignature{',isig,'}%' + else + if (islast) write(11,'(a18,i2,a2)') + * sq//'generalsignature{',isig,'}%' + end if + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + end if + if (parmov .ge. -.1) then +c +c Resent paragraph indentation +c + ipi = parmov*widthpt+.1 + if (ipi .lt. 10) then + if (islast) write(11,'(a11,i1,a2)') + * sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + if (islast) + * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + if (islast) + * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + end if + end if + if (isystpg .eq. 1) then +c +c First line on a page (not 1st page, still first bar). Tidy up old page +c then eject. +c +c Removed this 5/13/01 as it was causing double endvoltas. This probably +c is only needed at the end in case there is no endvolta specified. +c if (onvolt) then +cc if (islast) write(11,'(a)')sq//'endvoltabox%' +cc onvolt = .false. +c end if +c +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page. Ugly repeated coding here. +c + mtrnms = mtrnuml + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + mtrnuml = mtrnms + if (movbrk .eq. 0 .and. islast) + * call wgmeter(mtrnmp,mtrdnp) + end if +c +c Key signature change? +c + if (btest(iplnow,28) .and. movbrk.eq.0) then + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)') + * notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-'//sq//'afterruleskip}' + * //sq//'zstoppiece'//sq//'PMXbarnotrue%' + else if (mtrnuml.gt.0 .and. movbrk.eq.0) then +c +c Meter change but no signature change +c + if (islast) + * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'// + * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq// + * 'barnoadd%' + if (islast) + * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'// + * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%' + else + if (islast) write(11,'(a)')sq//'stoppiece%' + end if +c +c This is the key spot when vshrink is used. Value of vshrink here comes from +c just after the prior pagebreak, i.e., it is not affected by "Av" +c that may have been entered at this pagebreak, since that only affects usevshrink. +c So choose page *ending* (with or without \vfill) depending on old vshrink. Then +c check value of usevshrink to reset vshrink if necessary for the new page, where +c we have to set \interstaff and later call puttitle. +c Top of first page needs special treatment. For this we use +c novshrinktop, which was set in g1etnote on the first pass, since on +c second pass, vshrink at top of page one is dealt with in topfile, which is called +c *before* any reading in any "Av" at the top of the first input block. +c + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject%' + else + if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%' + end if + ipage = ipage+1 +c +c Now that page is ejected, compute new vshrink +c + vshrink = xintstaff(ipage).gt.20 .and. usevshrink + if (vshrink) then + xinsnow = 10 + else + xinsnow = xintstaff(ipage) + end if + if (fintstf.gt.0 .and. ipage.gt.1) then + xinsnow = xinsnow*fintstf/gintstf + fintstf = -1. + end if + if (xinsnow .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else if (xinsnow .lt. 99.95) then + fmtq = '(a,f4.1,a)' + else + fmtq = '(a,f5.1,a)' + end if +c +c Vertical spacing parameters, then restart +c + if (islast) write(11,fmtq)sq//'interstaff{',xinsnow, + * '}'//sq//'contpiece' +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a)')sq//'newtimes2%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + end if + end if + end if +c +c If no real titles here, which there probably will never be, make vertical +c space at page top with \titles{...}. headlog=.false.<=>no real titles +c + call puttitle(inhnoh,xnsttop(ipage),etatop, + * sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + else +c +c First bar of system, not a new page, force line break +c + if (btest(iplnow,28)) then +c +c Signature change +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (mtrnuml .ne. 0) then +c +c Meter+sig change, new line, may need mods if movement break here. +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) then + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def' + * 'addspace{-'//sq//'afterruleskip}' +c * //sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + write(11,'(a)')sq//'addspace{-'//sq + * //'afterruleskip}%' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'zchangecontext' + end if + else + if (islast) write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// + * 'addspace{-'//sq//'afterruleskip}' +c * sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'alaligne' + else +c +c New meter, no new sig, end of line, not new page. +c +c \generalmeter{\meterfrac{3}{4}}% +c \xchangecontext\addspace{-\afterruleskip}% +c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% +c \zchangecontext +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) then + write(11,'(a)') + * sq//'let'//sq//'bnat'//sq//'barnoadd' + * //sq//'def'//sq//'barnoadd{'//sq//'empty}%' + write(11,'(a)')sq//'xchangecontext'//sq// + * 'addspace{-'//sq//'afterruleskip}'//sq// + * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'zchangecontext' + end if + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + end if + end if +c +c Modified 090525 to use \bnrs +c + if (slint) then + slint = .false. + if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq// + * 'raisebarno{',irzbnd,'.5'//sq//'internote}%' + end if + movbrk = 0 + end if +c +c Clean up if we squelched bar number reset at movement break +c + if (nobar1) then + if (islast) write(11,'(a)')sq//'startbarno1' + nobar1 = .false. + end if + read(12,*,end=14)iauto +14 continue +c +c We come thru here for the 1st bar of every system, so initialize is1n1 +c + is1n1 = 0 +c +c Brought down from above +c + if (isystpg .eq. nsystp(ipage)) isystpg = 0 +c +c Check for linebreak ties +c + if (ispstie) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + else +c +c Not first bar of system +c + if (btest(iplnow,28)) then +c +c Signature change +c + if (mtrnuml .ne. 0) then +c +c Meter+signature change mid line, assume no movement break +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) call wgmeter(mtrnmp,mtrdnp) + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:18)//'-' + lnote = 19 + end if + if (islast) then + iptemp = 48+abs(isig) + charq = chax(iptemp) + notexq = notexq(1:lnote)//charq//'}%' + lnote = lnote+3 + write(11,'(a)')notexq(1:lnote) + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + write(11,'(a)')sq//'xchangecontext%' + end if + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = (facmtr+naccs*.24)*musicsize + end if + else +c +c Signature change only +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) + * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'// sq//'afterruleskip}%' + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = naccs*.24*musicsize + end if + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'xbar' + else +c +c Change meter midline +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'xbar' + end if + end if + end if + end if +c +c Now that xbar's are written, can put in left-repeats at line beginnings +c + if (lrptpend) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1' + * //sq//'leftrepeat' + lrptpend = .false. + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nolev(ivx,ip) = nolev(ivx,ip+ioff) + nodur(ivx,ip) = nodur(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) + irest(ivx,ip) = irest(ivx,ip+ioff) + islur(ivx,ip) = islur(ivx,ip+ioff) + ipl(ivx,ip) = ipl(ivx,ip+ioff) + iornq(ivx,ip) = iornq(ivx,ip+ioff) + mult(ivx,ip) = mult(ivx,ip+ioff) +c if (ivx.le.2 .and. figbass) +c * isfig(ivx,ip) = isfig(ivx,ip+ioff) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + if (ivx.eq.1) then + isfig(1,ip) = isfig(1,ip+ioff) + else + isfig(2,ip) = isfig(2,ip+ioff) + end if + end if +12 continue + if (ivx.le.nv .and. ncc(iv).gt.1) then + islide = 0 + do 13 icc = 1 , ncc(iv) + if (tcc(iv,icc) .le. lenbar) then +c +c This time will drop <=0 when slid. +c + islide = icc-1 + ncmidcc(iv,1) = ncmidcc(iv,icc) + else + tcc(iv,icc-islide) = tcc(iv,icc)-lenbar + ncmidcc(iv,icc-islide) = ncmidcc(iv,icc) + end if +13 continue + ncc(iv) = ncc(iv)-islide + tcc(iv,1) = 0. + end if +11 continue + do 15 ig = 1 , ngrace + ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1) + if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2) +15 continue + do 21 il = 1 , nlit + iplit(il) = iplit(il)-nib(ivlit(il),ibar-1) + if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2) +21 continue + do 22 it = 1 , ntrill + iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1) + if (ibar .gt. 2) iptrill(it) = + * iptrill(it)+nib(ivtrill(it),ibar-2) +22 continue + do 27 icrd = 1 , ncrd +c ivx = iand(15,ishft(icrdat(icrd),-8)) + ivx = iand(15,ishft(icrdat(icrd),-8)) + * +16*igetbits(icrdat(icrd),1,28) + ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + icrdat(icrd) = iand(not(255),icrdat(icrd)) + icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd)) +27 continue + do 29 iudorn = 1 , nudorn +c ivx = iand(15,ishft(kudorn(iudorn),-8)) + ivx = ivxudorn(iudorn) + ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + kudorn(iudorn) = iand(not(255),kudorn(iudorn)) + kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn)) +29 continue + do 42 idyn = 1 , ndyn + idynd = idyndat(idyn) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10) + ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) +c +c The following construction avoids array bound errors in some compilers +c + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(idynd,8,4,ipnew) + idyndat(idyn) = idynd +42 continue + do 43 itxtdyn = 1 , ntxtdyn + idynd = ivxiptxt(itxtdyn) +c ivx = iand(15,idynd) + ivx = iand(31,idynd) +c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) + ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) +c call setbits(idynd,8,4,ipnew) + call setbits(idynd,8,5,ipnew) + ivxiptxt(itxtdyn) = idynd +43 continue + do 41 isdat = 1 , nsdat + isdata = isdat1(isdat) + ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1) + ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(isdata,8,3,ipnew) + isdat1(isdat) = isdata +41 continue + do 44 ibc = 1 , nbc +c ivx = iand(15,ibcdata(ibc)) + ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(ibcdata(ibc),8,4,ipnew) +44 continue + do 45 iarps = 1 , NumArpShift + IpArpShift(iarps) = + * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1) + if (ibar .gt. 2) then + IpArpShift(iarps) = + * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2) + end if +45 continue +c +c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. +c If there are figs left, it will reset all times relative to start of +c current bar. +c + do 46 ivx = 1 , 2 + if (figbass) then + islide = 0 + do 20 jfig = 1 , nfigs(ivx) + if (itfig(ivx,jfig) .lt. lenbar) then +c +c This figure was already used +c + islide = jfig + else + itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar + figq(ivx,jfig-islide) = figq(ivx,jfig) + itoff(ivx,jfig-islide) = itoff(ivx,jfig) + ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig) + end if +20 continue + nfigs(ivx) = nfigs(ivx)-islide + end if + if (nfigs(2) .eq. 0) go to 47 +46 continue +47 continue + end if +c +c End of sliding down for bars after first in gulp. +c +c The following may not be needed by makeabar, but just in case... +c + if (firstgulp .and. lenb0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenb0 + else + lenbar = lenb1 + end if + end if +c +c Equal line spacing stuff +c + if (equalize .and. bar1syst) then + if (isystpg .eq. 1) then + write(11,'(a)')sq//'starteq%' + else if (isystpg .eq. nsystp(ipage)-1) then + write(11,'(a)')sq//'endeq%' + end if + end if + call make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + call make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) +c +c Hardspace before barline? +c + hardb4 = 0. + do 35 iv = 1 , nv + do 35 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (btest(irest(ivx,nn(ivx)),18)) then + nudoff(ivx) = nudoff(ivx)+1 + hardb4 = max(hardb4,udoff(ivx,nudoff(ivx))) + end if +35 continue + if (hardb4 .gt. 0.) then + if (islast) write(11,'(a11,f5.1,a4)')sq + * //'hardspace{',hardb4,'pt}%' + fixednew = fixednew-hardb4 + end if +10 continue + firstgulp = .false. + lenb0 = 0 + go to 30 +40 close(12) + close(13) + ilbuf = 1 + ipbuf = 0 + wdpt = widthpt + if (iline .eq. 1) wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + poevec(nsyst) = poe + if (.not.islast) then + close(11) + close(16) + if (figbass) close(14) + return + end if + do 19 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +19 continue + do 26 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +26 continue + if (islast .and. + * onvolt) write(11,'(a)')sq//'endvoltabox' + if (rptfq2 .ne. 'E') then +c +c Terminal repeat. Right or double? +c + if (rptfq2 .eq. 'r') then + if (islast) write(11,'(a)')sq//'setrightrepeat' + * //sq//'endpiece' + else if (rptfq2 .eq. 'd') then + if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece' + else if (rptfq2 .eq. 'b') then + if (islast) write(11,'(a)')sq//'endpiece' + else if (rptfq2 .eq. 'z') then + if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece' + else +c else if (rptfq2 .ne. 'D') then + print* + print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + if (islast) write(11,'(a)')sq//'Endpiece' + end if + else + if (islast) write(11,'(a)')sq//'Endpiece' + end if + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + else + if (islast) write(11,'(a)') + * sq//'vfill'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + end if + rewind(11) + if (figbass) then + write(14,'(a9,i2,a10,i2,1x,a5)') + * sq//'figdrop=',ifigdr(1,iline), + * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%' + rewind(14) + end if + call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + if (.not.optimize) then + print* + print*,'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + print*,'Done with second PMX pass.' + write(15,'(/,a)')'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + write(15,'(a)')' Done with second PMX pass. Now run TeX' + end if + return + end + subroutine poestats(nsyst,poe,poebar,devnorm) + parameter (nks=125) +c +c Compute avg. & norm. std. dev. of poe. +c + real*4 poe(nks) + sumx = 0. + sumxx = 0. + do 1 isyst = 1 , nsyst + sumx = sumx+poe(isyst) + sumxx = sumxx+poe(isyst)**2 +1 continue +2 continue + devnorm = sqrt(nsyst*sumxx/sumx**2-1) + poebar = sumx/nsyst + return + end + subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq, + * twooftwo,icashft) +c +c Analyzes chords, data to be used with slurs on chords and plain chords. +c Check for 2nds, shift notes if neccesary. +c ipl(10) chord present +c irest(20) set if any note is right shifted +c irest(27) set if any note is left shifted +c ipl(8|9) left|right shift main note +c icrdat(23|24) ditto chord note +c udq is updown-ness, needed to analyze 2nds. +c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. +c icrdot(icrd)(27-29) sequence order of chord note if accid, top down +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,is2nd,twooftwo + integer*4 kicrd(10),levtabl(88) + character*1 udq + do 11 i = 1 , 88 + levtabl(i) = 0 +11 continue + do 1 icrd1 = 1 , ncrd + ivx1 = iand(15,ishft(icrdat(icrd1),-8)) + * +16*igetbits(icrdat(icrd1),1,28) + ip1 = iand(255,icrdat(icrd1)) + if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2 +1 continue + print* + print*, + * 'Cannot find first chord note in precrd. Send source to Dr. Don!' + call stop1() +2 continue + maxlev = nolevm + minlev = nolevm + levtabl(nolevm) = -1 + is2nd = .false. + naccid = 0 + levmaxacc = -100 + levminacc = 1000 +c +c Check 1st 3 bits of nacc for accid on main note of chord. +c + if (iand(7,nacc) .gt. 0) then + naccid = 1 +c +c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, +c otherwise icrd value for note with accidental. +c + kicrd(1) = 0 + levmaxacc = nolevm + levminacc = nolevm +c +c Start the level-ranking +c + icrdot0 = 1 + end if + do 3 icrd2 = icrd1 , ncrd + nolev = igetbits(icrdat(icrd2),7,12) + levtabl(nolev) = icrd2 + maxlev = max(maxlev,nolev) + minlev = min(minlev,nolev) +c +c Check for accidental +c + if (btest(icrdat(icrd2),19)) then + naccid = naccid+1 + levmaxacc = max(levmaxacc,nolev) + levminacc = min(levminacc,nolev) +c +c Add this icrd to list of values for notes with accid's. +c + kicrd(naccid) = icrd2 + if (.not.btest(nacc,28)) then +c +c Order not forced, so get the level-ranking, top down +c + iorder = 1 + do 12 iaccid = 1 , naccid-1 + if (kicrd(iaccid) .eq. 0) then + if (nolevm .gt. nolev) then + iorder = iorder+1 + else + icrdot0 = icrdot0+1 + end if + else + if (igetbits(icrdat(kicrd(iaccid)),7,12) + * .gt. nolev) then + iorder = iorder+1 + else + iold = igetbits(icrdot(kicrd(iaccid)),3,27) + call setbits(icrdot(kicrd(iaccid)),3,27,iold+1) + end if + end if +12 continue + call setbits(icrdot(icrd2),3,27,iorder) + end if + end if +c +c Exit loop if last note in this chord +c + if (icrd2 .eq. ncrd) go to 4 + if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or. +c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 + * igetbits(icrdat(icrd2+1),4,8) + * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4 +3 continue + print* + print*,'Failed to find last chord note. Send source to Dr. Don!' + call stop1() +4 continue +c +c Now icrd1, icrd2 define range of icrd for this chord. +c +c Bypass autos-shifting if any manual shifts are present +c + if (btest(irest,20) .or. btest(irest,27)) go to 10 +c +c Check for 2nds +c + do 5 ilev = 1 , 87 + if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then +c +c There is at least one 2nd.. +c + if (udq .eq. 'u') then +c +c Upstem. Start with 2nd just found and go up, rt-shifting upper +c member of each pair +c + ile = ilev +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,20) +7 continue + if (levtabl(ile+1) .lt. 0) then +c +c Upstem, & upper member is main so must be rt-shifted. This would move +c stem too, so we rt-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,30) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24) + else +c +c Upper member is chord note, must be rt-shifted +c + icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24) + end if + ile = ile+1 +8 continue + ile = ile+1 + if (ile .lt. 87) then + if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then + go to 7 + else + go to 8 + end if + end if + go to 10 + else +c +c Downstem. Start at top and work down, left-shifting lower member of each pair. +c We know that lowest pair is at (ilev,ilev+1). +c + ile = 88 +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,27) +9 continue + if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then + if (levtabl(ile-1) .lt. 0) then +c ipl = ibset(ipl,8) +c +c Dnstem, & lower member is main so must be left-shifted. This would move +c stem too, so we left-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,31) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23) + else +c +c Lower member is chord note, must be shifted +c + icrdat(levtabl(ile-1)) = + * ibset(icrdat(levtabl(ile-1)),23) + end if + ile = ile-1 + end if + ile = ile-1 + if (ile .ge. ilev+1) go to 9 + go to 10 + end if + end if +5 continue +10 continue +c +c Done with 2nds, now do accid's. Call even if just one, in case left shifts. +c +c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, + if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid, + * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft) + return + end + subroutine printl(string) + character*(*) string +c +c Send string to console and to log file +c + print*,string + write(15,'(a)')string + return + end + subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + logical lowdot,IsArpShift + character*80 soutq + character*79 notexq + character*8 symq(2) + character*1 chax + data symq /'raisearp','arpeggio'/ + +c +c Find which iarp, if any +c + do 1 iarp = 1 , narp + if (abs(tnow-tar(iarp)).lt.tol) go to 2 +1 continue +c +c If here, this is the *first* call for this arp. +c + narp = narp+1 + tar(narp) = tnow+tol*.5 + ivar1(narp) = iv + ipar1(narp) = ip + levar1(narp) = nolev + ncmar1(narp) = ncm + return +2 continue +c +c If here, this is *second* call at this time, iarp points to values from 1st. +c +c Check for shift. Set IsArpShift and iarps +c + do 3 iarps = 1 , NumArpShift + if (IvArpShift(iarps) .eq. ivar1(iarp) .and. + * IpArpShift(iarps) .eq. ipar1(iarp)) then + IsArpShift = .true. + notexq = chax(92)//'loffset{' + write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{' + lnote = 14 + go to 4 + end if +3 continue + IsArpShift = .false. + lnote = 0 +4 continue + if (iv .eq. ivar1(iarp)) then +c +c Arp is in a single staff. +c + levbot = min(levar1(iarp),nolev)-ncm+3 + invert = abs(levar1(iarp)-nolev)+1 + else +c +c Arp covers >1 staff. Lower staff has to be the first, upper is current and +c is where the symbol will be written. +c + levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) + invert = -levbot+4+nolev-ncm +c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' +c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), +c *levbot,nolev,ncm + end if +c +c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote +c + isym = mod(invert,2)+1 + ilvert = (invert+1)/2 + if (levbot .ge. 0 .and. levbot .le. 9) then +c +c Single digit +c + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//chax(48+levbot) + else + notexq = notexq(1:lnote)// + * chax(92)//symq(isym)//chax(48+levbot) + end if + lnote = lnote+10 + else + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//'{' + else + notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{' + end if + lnote = lnote+10 + if (levbot .ge. -9) then +c +c Need two spaces for number +c + write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}' + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}' + lnote = lnote+4 + end if + end if +c if (ilvert .le. 9) then +c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, +c * soutq,lsout) +c else +c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' +c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) +c end if + + if (ilvert .gt. 9) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+ilvert) + lnote = lnote+1 + end if + if (IsArpShift) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) +c +c cancel out the stored time, to permit two arps at same time! +c + tar(iarp) = -1. + return + end + subroutine putast(elask,indxask,outq) + character*129 outq,tag + character*9 fmtq + if (elask .ge. 0.) then + if (elask.lt.0.995) then + lp = 3 + else if (elask .lt. 9.995) then + lp = 4 + else + lp = 5 + end if + write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)' + else + lp = 5 + fmtq = '(a2,f5.1)' + end if +c +c Overwrite as follows: ...xyz*ask *lmnop... -> +c ...xyz*ast{.nn}*lmnop... +c ...xyz*ast{n.nn}*lmnop... +c ...xyz*ast{nn.nn}*lmnop... +c or for negative, ...xyz*ast{-nn.n}*lmnop... + tag = outq(indxask+9:) + write(outq(indxask+3:),fmtq)'t{',elask + outq = outq(1:indxask+4+lp)//'}'//tag + return + end + subroutine putcb(ivx,ip,notexq,lnote) + common /comcb/ nbc,ibcdata(36) + character*79 notexq + logical btest +c ivxip = ivx+16*ip + do 1 ibc = 1 , nbc +c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 +c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) +c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 + ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipbc = igetbits(ibcdata(ibc),8,4) + if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2 +1 continue + call printl('Error in putbc, Call Dr. Don') + stop +2 continue + if (btest(ibcdata(ibc),27)) then + lnote = 8 + notexq = char(92)//'pbreath' + else + lnote = 9 + notexq = char(92)//'pcaesura' + end if + ivshft = igetbits(ibcdata(ibc),6,13) +c?? ivshft = igetbits(ibcdata(ibc),6,13)-32 + if (ivshft .gt. 0) ivshft = ivshft-32 + if (ivshft.lt.0 .or. ivshft.gt.9) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (ivshft .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')ivshft + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')ivshft + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + notexq = notexq(1:lnote)//char(48+ivshft) + lnote = lnote+1 + end if + ihshft = igetbits(ibcdata(ibc),8,19) + if (ihshft .eq. 0) then + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else + hshft = .1*(ihshft-128) +c +c -12.81 ornament on a note, next line is top of manual loop. +c +2 continue +c +c Bit # of last ornament (last of bits 0-21) +cc Bit # of last ornament (last of bits 0-24) + ibit = log2(iand(iornq,4194303)) +c ibit = log2(iand(iornq,33554431)) + iornt = 2**ibit +c +c Begin routine to set height. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c 19-20: >^, 21: ? (with or w/o 16-18) +c +c Do not use beam height for . or _ +c + if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then +c +c Height is set by special beam stuff. +c Do not leave ihorn set, do separately for every ornament +c + ihorn = ihornb(ivx,nornb(ivx)) + if (ulpzq .eq. 'u') ihorn = ihorn-2 +c +c Following flag tells whether to increment nornb when exiting the subroutine. +c + usehornb = .true. + else if (ibit .eq. 14) then +c +c Down fermata. Don't worry about upper chord notes. +c + if (ulpzq .eq. 'l') then + ihorn = min(nolev,ncm-3) + else + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (btest(iornt,13) .or. btest(iornt,0)) then +c +c ( or ) +c + ihorn = nolev + else if (iand(iornt,6144) .gt. 0) then +c +cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info +c NOTE: removed .&_ from special beam treatment. +c Staccato . or tenuto _ Need up-down info +c + if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or. + * (minlev.ne.nolev.and.ulpzq.eq.'u')) then + ihorn = nolev + else if (maxlev .eq. nolev) then + ulpzq = 'u' + ihorn = max(nolev+stemlen,ncm+3.) + else + ulpzq = 'l' + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (iscrd .and. nolev .eq. minlev) then + if (ulpzq .eq. 'l') then + ihorn = min(nolev-3,ncm-6) + else + ihorn = min(nolev-nint(stemlen)-3,ncm-6) + end if + else if (ibit.eq.10 .and. nolev.gt.90) then +c +c Special treatment for fermata on a shifted rest +c + ihorn = ncm+5 + else if (ulpzq.eq.'l') then +c +c (iscrd and nolev=maxlev) or (.not.iscrd) +c + ihorn = max(nolev+stemlen+2,ncm+5.) + else + ihorn = max(nolev+2,ncm+5) + end if + ioff = 0 + iclracc = 0 +c +c Begin routine to set name. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c + if (btest(iornt,2)) then + notexq = sq//'shake' + lnote = 6 + else if (btest(iornt,3)) then + notexq = sq//'mordent' + lnote = 8 + else if (btest(iornt,1)) then + notexq = sq//'mtr' + lnote = 4 + else if (btest(iornt,5)) then + notexq = sq//'xtr' + lnote = 4 + else if (btest(iornt,6)) then + notexq = sq//'ptr' + lnote = 4 + else if (btest(iornt,13)) then + notexq = sq//'rpn' + lnote = 4 + else if (btest(iornt,0)) then + notexq = sq//'lpn' + lnote = 4 + else if (btest(iornt,12)) then + notexq = sq//ulpzq//'st' + lnote = 4 + else if (btest(iornt,11)) then + notexq = sq//ulpzq//'pz' + lnote = 4 + else if (btest(iornt,8)) then + notexq = sq//'upz' + lnote = 4 + ioff = -2 + else if (btest(iornt,9)) then + notexq = sq//'uppz' + lnote = 5 + ioff = -2 + else if (btest(iornt,10)) then + if (nodur .lt. 48) then + notexq = sq//'fermataup' + else + notexq = sq//'Fermataup' + end if + lnote = 10 + ioff = -2 + else if (btest(iornt,14)) then + if (nodur .lt. 48) then + notexq = sq//'fermatadown' + else + notexq = sq//'Fermatadown' + end if + lnote = 12 + else if (btest(iornt,21)) then +c +c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 +c + if (btest(iornq,16)) then + notexq = sq//'qsharp' + lnote = 7 + ioff = 2 + iornq = ibclr(iornq,16) + iclracc = 16 + else if (btest(iornq,17)) then + notexq = sq//'qflat' + lnote = 6 + ioff = 1 + iornq = ibclr(iornq,17) + iclracc = 17 + else if (btest(iornq,18)) then + notexq = sq//'qnat' + lnote = 5 + ioff = 2 + iornq = ibclr(iornq,18) + iclracc = 18 + else + notexq = sq//'qedit' + lnote = 6 + ioff = 0 + end if + else if (btest(iornt,16)) then + notexq = sq//'esharp' + lnote = 7 + ioff = 2 + else if (btest(iornt,17)) then + notexq = sq//'eflat' + lnote = 6 + ioff = 1 + else if (btest(iornt,18)) then + notexq = sq//'enat' + lnote = 5 + ioff = 2 + else if (btest(iornt,19)) then + notexq = sq//'usf' + lnote = 4 + ioff = -2 + else if (btest(iornt,20)) then + notexq = sq//'usfz' + lnote = 5 + ioff = -2 + end if + iudorn = 0 +c +c User-defined level shift of ornament from default? +c + if (btest(iornq,25)) then +c +c Find which (if any) element of kudorn has the shift. +c + do 3 iudorn = 1 , nudorn + if (ibit .lt. 21) then + ibitt = ibit +c +c Could have oes, but not oe? or oes? +c + else if (iclracc .gt. 0) then +c +c Earlier cleared edit. accid, meaning it was oes? +c + ibitt = iclracc+6 + else + ibitt = 21 + end if + ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19) +c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 + if (ibitt .eq. iand(33554431,kudorn(iudorn)) + * .and. ivx.eq.ivxudorn(iudorn)) go to 4 +3 continue +c +c Nothing shifted on this note; exit this if block +c + iudorn = 0 + go to 5 +4 continue + ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32 + if (ibit.eq.19 .and. ioffinc .lt. -7) then +c +c Convert usf to lsf. The reason has to do with positioning being impossile +c for some mysterious reason when you drop \usf below the staff +c + notexq = sq//'lsf' + ioffinc = ioffinc+6 + end if + ioff = ioff+ioffinc + end if +5 continue +c +c Shift level to avoid slur. Conditions are +c 1. There is a slur +c 2. No user-defined orn height shift (btest(iornq,25)) +c 3. upslur (islhgt>0) +c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 +c 5. islhgt+3 >= height already computed. +c + if (.not.btest(iornq,25) .and. + * islhgt.gt.0 .and. iand(iornt,30737).eq.0) + * ioff = ioff+dim(islhgt+3,ihorn ) + call notefq(noteq,lnoten,ihorn+ioff,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) + if (iand(iornt,32896) .gt. 0) then +c +c T-trill or trill w/o "tr" +c + call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote) + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + if (iudorn .gt. 0) then + if (btest(kudorn(iudorn),31)) then +c +c Horizontal shift +c + lform = lfmt1(ornhshft(iudorn)) + write(noteq(1:lform),'(f'//chax(48+lform)//'.1)') + * ornhshft(iudorn) + notexq = sq//'roffset{'//noteq(1:lform)//'}{' + * //notexq(1:lnote)//'}' + lnote = lnote+lform+12 + ornhshft(iudorn) = 0. + kudorn(iudorn) = ibclr(kudorn(iudorn),31) + end if + end if +c +c Zero out the bit for ornament just dealt with. +c + iornq = ibclr(iornq,ibit) + if (lout .eq. 0) then + outq = notexq(1:lnote) + else + outq = outq(1:lout)//notexq(1:lnote) + end if + lout = lout+lnote +c +c Check bits 0-21, go back if any are still set +c + if (iand(iornq,4194303) .gt. 0) go to 2 + if (usehornb) nornb(ivx) = nornb(ivx)+1 + return + end + subroutine putshft(ivx,onoff,soutq,lsout) + parameter (nm=24) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + character*80 soutq,notexq + character*1 sq,chax + logical onoff + sq = chax(92) +c +c Start user-defined offsets X(...): or X(...)S +c + if (onoff) nudoff(ivx) = nudoff(ivx)+1 +c +c Xoff is in pts. Round off to nearest .1. Will use at end of shift. +c + xoff = udoff(ivx,nudoff(ivx)) + xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff) + if (.not.onoff) xoff = -xoff + if (xoff .lt. -9.95) then + ifmt = 5 + else if (xoff.lt.-.95 .or. xoff.gt.9.95) then + ifmt = 4 + else + ifmt = 3 + end if + write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff + call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt, + * soutq,lsout) + return + end + subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc, + * etacs1,nv,vshrink,sepsymq) +c +c Called once per page, at top of page! If vshrink, only called for p.1. +c Actual titles only allowed on p.1. (set by headlog). +c 3/18/01: The above comment is probably bogus...can use Tt on later pages. +c + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + character*127 notexq + character*120 instrq,titleq,compoq + parameter (nm=24) + character*1 sq,sepsymq(nm),chax + logical headlog,vshrink + notexq = sq//'znotes' + lenline = 7 + do 22 iv = 1 , nv-1 + notexq = notexq(1:lenline)//sepsymq(iv) + lenline = lenline+1 +22 continue + notexq = notexq(1:lenline)//sq//'zcharnote{' + lenline = lenline+11 + if (.not.headlog) then + inhead = inhnoh + end if + if (vshrink .and. usevshrink) then + inhead = 16 + end if + ndig = int(alog10(inhead+.01))+1 + write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)// + * ',a10)')inhead,'}{'//sq//'titles{' + lenline = lenline+ndig+10 +c +c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether +c headers are present or not. +c + glueil = xnsttop/etatop + vskil = etatop*glueil + if (vshrink .and. usevshrink) vskil = 2 + call writflot(vskil,notexq,lenline) + if (.not.headlog) then + if (islast) write(11,'(a)')notexq(1:lenline) + * //'}{}{0}{}{0}{}{0}}'//sq//'en%' + else + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + lcq = lenstr(instrq,120) + if (lcq .gt. 0) then + xitil = etait*glueil + if (vshrink .and. usevshrink) xitil = 2 + notexq = notexq(1:lenline)//instrq(1:lcq)//'}{' +c +c Null out instrument once used +c + instrq = ' ' + lenline = lenline+lcq+2 + call writflot(xitil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}%' + notexq = '{' + lenline = 1 + lcq = lenstr(titleq,120) + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//titleq(1:lcq) + lenline = lenline+lcq + else + call printl(' ') + call printl('WARNING') + call printl( + * ' In a title block, you have specified instrument and/or') + call printl( + * ' composer but no title for the piece.') + end if + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + xtcil = etatc*glueil + lcq = lenstr(compoq,120) + if (lcq .eq. 0) xtcil = 2*xtcil + if (vshrink .and. usevshrink) xtcil = 2 + call writflot(xtcil,notexq,lenline) + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//compoq(1:lcq)//'}{' + lenline = lenline+2+lcq +c +c Null out compoq so it does not get written later +c + compoq = ' ' + xcsil = etacs1*glueil + if (vshrink .and. usevshrink) xcsil = 2 + call writflot(xcsil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%' + headlog = .false. + end if + return + end + subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom, + * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum, + * eloff,iup,irest,usexnumt) +c +c Places digit for xtuplet. +c + character*1 chax + character*8 noteq + character*79 notexq + logical btest,usexnumt + if (iflop.ne.0 .and. multb.gt.0) then +c +c Number goes on beam side, move R/L by .5 wheadpt for upper/lower +c + eloff = eloff-0.5*iud*wheadpt/poenom +c +c Number goes on beam side, must use beam parameters to set pos'n +c + nlnum = nolev1+islope/slfac*eloff+iup*(multb+8) + if (multb .ge. 2) nlnum = nlnum+iup + else + nlnum = nint(xnlmid-1+3*iud+iflop*11) + end if + if (.not.btest(islur,31)) then +c +c Only print number when wanted. First check vert, horiz offset +c + if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 + if (btest(irest,7)) eloff = eloff+ + * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom + if (.not.usexnumt) then + notexq = chax(92)//'xnum{' + lnote = 10 + istrtn = 7 + else + notexq = chax(92)//'xnumt{' + lnote = 11 + istrtn = 8 + end if + if (eloff .lt. 0.995) then + write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff + else if (eloff .lt. 9.995) then + write(notexq(istrtn:istrtn+3),'(f4.2)')eloff + else + write(notexq(istrtn:istrtn+4),'(f5.2)')eloff + lnote = lnote+1 + end if + call notefq(noteq,lnoten,nlnum,ncmid) + notexq = notexq(1:lnote)//'}'//noteq(1:lnoten) + lnote = lnote+1+lnoten + if (ntupv .lt. 10) then + write(notexq(lnote+1:lnote+1),'(i1)')ntupv + lnote = lnote+1 + else + notexq = notexq(1:lnote)//'{' + write(notexq(lnote+2:lnote+3),'(i2)')ntupv + notexq = notexq(1:lnote+3)//'}' + lnote = lnote+4 + end if + end if + return + end + subroutine read10(string,lastchar) + parameter (maxblks=4000) + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*(*) string + character*128 lnholdq + logical lastchar + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + if (.not.mplay) then + if (ilbuf .gt. nlbuf) go to 999 + call getbuf(string) + return +999 lastchar = .true. + return + else +c +c Play a macro. Set pointer to first character needed in buffer +c + if (ilmac .eq. il1mac(macnum)) then +c +c Getting first line of macro +c + ip1 = ip1mac(macnum) + iplmac = ip1-ic1mac(macnum) + else if (ilmac .le. il2mac(macnum)) then +c +c Beyond first line of macro. Advance line-start pointer. +c + iplmac = iplmac+lbuf(ilmac-1) + ip1 = iplmac+1 + else +c +c Beyond last line of macro. Terminate it! +c + mplay = .false. + endmac = .true. + return + end if + if (ilmac .eq. il2mac(macnum)) then +c +c Getting last line of macro. +c + ip2 = ip2mac(macnum) + else +c +c Getting line before last line of macro. +c + ip2 = iplmac+lbuf(ilmac) + end if + if (ip2 .ge. ip1) then + string = bufq(ip1:ip2) + else +c +c Kluge for when macro start is on a line by itself +c + string = ' ' + end if + ilmac = ilmac+1 + return + end if + end + function readin(lineq,iccount,nline) +c +c Reads a piece of setup data from file lineq, gets a new lineq from +c file 10 (jobname.pmx) and increments nline if needed, passes over +c comment lines +c + character*128 lineq + character*1 durq,chax +4 if (iccount .eq. 128) then +1 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 1 + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (lineq(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(lineq,iccount,durq) +c +c Remember that getchar increments iccount, then reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin + return + end + subroutine readmeter(lineq,iccount,mtrnum,mtrden) + character*128 lineq + character*1 durq,chax + if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then +c +c No slashes, so use old method +c + call getchar(lineq,iccount,durq) + if (durq .eq. '-') then +c +c Negative numerator is used only to printed; signals vertical slash +c + call getchar(lineq,iccount,durq) + mtrnum = -(ichar(durq)-48) + else if (durq .eq. 'o') then +c +c Numerator is EXACTLY 1 +c + mtrnum = 1 + else + mtrnum = ichar(durq)-48 + if (mtrnum .eq. 1) then +c +c Numerator is >9 +c + call getchar(lineq,iccount,durq) + mtrnum = 10+ichar(durq)-48 + end if + end if + call getchar(lineq,iccount,durq) + if (durq .eq. 'o') then + mtrden = 1 + else + mtrden = ichar(durq)-48 + if (mtrden .eq. 1) then + call getchar(lineq,iccount,durq) + mtrden = 10+ichar(durq)-48 + end if + end if + else +c +c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' +c + iccount = iccount+1 + ns = index(lineq(iccount:128),'/') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum +c +c Reset iccount to start of second integer +c + iccount = iccount+ns +c +c There must be either a slash or a blank at pos'n 2 or 3 +c + ns = index(lineq(iccount:iccount+2),'/') + if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden +c +c Set iccount to last character used +c + iccount = iccount+ns-1 + end if + return + end + subroutine readnum(lineq,iccount,durq,fnum) +c +c This reads a number starting at position iccount. Remember that on exit, +c getchar leaves iccount at the last character retrieved. So must only +c call this routine *after* detecting a number or decimal. +c On exit, durq is next character after end of number. +c + character*128 lineq + character*1 durq,chax + i1 = iccount +1 call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .gt. 0) go to 1 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then + i2 = i2-1 + iccount = iccount-1 + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum + return + end + subroutine setbits(isdata,iwidbit,ishift,ivalue) +c +c Sets iwidbits of isdata, shifted by ishift, to ivalue +c + ibase = 2**iwidbit-1 + if (ivalue.gt.ibase) then + print* + print*,'WARNING in setbits: ivalue > ibase' + write(15,'(/,a)')'WARNING in setbits: ivalue > ibase' + end if + isdata = iand(not(ishft(ibase,ishift)),isdata) + isdata = ior(isdata,ishft(ivalue,ishift)) + return + end + subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1) +c +c The MEAN SQUARE slope algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig + real*4 xelsk(24) + integer ipb(24) + ibc = ibmcnt(ivx) + sumxx = 0. + sumxy = 0. + do 2 inb = 1 , nnb + sumxx = sumxx+xelsk(inb)**2 + sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb)) +2 continue + delta = nnb*sumxx-sumx*sumx + em = (nnb*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*slfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/slfac*sumx)/nnb + nolev1 = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + do 4 inb = 1 , nnb + ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac + ynote = nolev(ivx,ipb(inb)) + smin = min(smin,iul*(ybeam-ynote)) +4 continue + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolev1 = nint(nolev1+iul*deficit) + end if + return + end + subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq, + * ivx,nline) + character*1 charq,durq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,btest + character*128 lnholdq,lineq + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac +c +c Macro action +c + call g1etchar(lineq,iccount,charq) + if (charq.eq.'S' .and. ivx.ne.1) then + print* + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"MS..." only put in parts by scor2prt if in voice #1!') + end if + if (index('RSP ',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "M" (macro)!') + call stop1() + else if (charq .ne. ' ') then +c +c Record or playback a macro. Get the number of the macro. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must input number after "MR","MP", or "MS"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macro number must be followed by a blank!') + call stop1() + end if + if (index('RS',charq ).gt. 0) then +c +c Record or save a macro +c + if (macnum.lt.1 .or. macnum.gt.20) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Macro number not in range 1-20!') + call stop1() +c else if (btest(macuse,macnum)) then +c print* +c print*,'WARNING: Redefining macro # ',macnum + end if + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + else if (charq .eq. 'S') then +c +c Save (Record but don't activate) +c +1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + if (mrecord) then + call getbuf(lineq) + nline = nline+1 + iccount = 0 + go to 1 + end if + iccount = iccount+ndxm+1 + end if + else +c +c Playback the macro +c + if (.not.btest(macuse,macnum)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a macro that has not been recorded!') + call stop1() + end if + icchold = iccount + lnholdq = lineq + iccount = 128 + mplay = .true. + ilmac = il1mac(macnum) + end if + end if + return + end + subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) +c +c Sets last 2 args depending on 1st 2, (logical) num, denom. +c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. +c 1: all duple meters +c 2: triple w/ denom=4, subdivide in groups of 2 8ths +c 3: triple w/ denom=8, subdivide in groups of 3 8ths +c Note that lenbar is set at top or when 'm' symbol is read in getnote +c + if (mtrdenl .eq. 4) then + if (mod(mtrnuml,3) .eq. 0) then + ibmtyp = 2 + ibmrep = mtrnuml/3 + else + ibmtyp = 1 + ibmrep = mtrnuml/2 + end if + else if (mtrdenl .eq. 2) then + ibmtyp = 1 + if (mtrnuml .eq. 3) then + ibmrep = 3 + else + ibmrep = 2*mtrnuml/mtrdenl + end if + else +c +c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 +c + ibmtyp = 3 + ibmrep = mtrnuml/3 + end if +c +c Reset so we don't keep writing new meters +c + mtrnuml = 0 +c +c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter +c + ibmrep = max(ibmrep,1) + return + end + subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest) +c +c The outer combo algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm + common /comeskz2/ eskz2(nm,200) + real*4 slope(800),xelsk(24) + integer ipb(24) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xels11(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + ibc = ibmcnt(ivx) + nxtinbm(ivx) = 0 + n1 = ipl2(ivx,ibm1(ivx,ibc)) +c +c Initialize counters used in this subroutine, and then later during actual +c beam drawing, to count later segments of single-slope beam groups +c + nssb(ivx) = 0 + issb(ivx) = 0 +c +c Set flag for xtup beam starting with rest (no others can start with rest) +c + if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1 +c +c Figure how many elemskips to each note. Use the list, counting only non-rests. +c + eskz0 = eskz(ivx,ibm1(ivx,ibc)) + nnb = 0 + sumx = 0. + sumy = 0. + ipxt1 = 0 + iplast = ibm2(ivx,ibc) + do 2 ip = ibm1(ivx,ibc) , iplast + if (.not.btest(irest(ivx,ip),0)) then + nnb = nnb+1 + ipb(nnb) = ip + xelsk(nnb) = eskz(ivx,ip)-eskz0 + sumx = sumx+xelsk(nnb) + sumy = sumy+nolev(ivx,ipb(nnb)) + if (btest(nacc(ivx,ip),21)) then +c +c This is the starting note of later segment of single-slope beam group +c Temporarily store ip here. +c + nssb(ivx) = nssb(ivx)+1 + lev1ssb(ivx,nssb(ivx)) = nnb + end if + end if +c +c New xtup stuff here. Final object is to get distance from start of xtup +c to number. xtinbm counts xtups in this beam only. mtupv is the printed +c number. ntupv is number of notes in xtup, and is only used to get +c eloff, the distance from start of xtup to the number. +c + if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1 + if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then +c +c Xtup is starting here +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + ipxt1 = ip + if (btest(nacc(ivx,ip),18)) then + ndoub = 1 + else + ndoub = 0 + end if + else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then +c +c Xtup ends here. Set total number of notes in xtup. +c + ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1 +c +c Set printed number for embedded xtup. +c + mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub +c +c Middle note of xtup if ntupv odd, note to left of gap if even. +c + ipxtmid = (ip+ipxt1)/2 + eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) + * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+ + * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid)) + ipxt1 = 0 + end if +2 continue +c +c Reset nxtinbm for use as counter as #'s are posted by putxtn(..) +c + nxtinbm(ivx) = 0 + smed = 0. + if (.not.btest(islur(ivx,ipb(1)),2)) then +c +c No forced 0 slope +c + if (nnb .eq. 1) go to 6 + nsc = 0 + do 5 inb = 1 , nnb-1 + do 5 jnb = inb+1 , nnb + nsc = nsc+1 + slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/ + * (xelsk(jnb)-xelsk(inb)) + if (abs(slope(nsc)) .lt. 1.e-4) then + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + end if +5 continue + if (nsc .eq. 1) then + smed = slope(1) + go to 6 + end if + nscmid = nsc/2+1 + do 7 i = 1 , nscmid + do 7 j = i+1 , nsc + if (slope(j) .lt. slope(i)) then + t = slope(j) + slope(j) = slope(i) + slope(i) = t + end if +7 continue + smed = slope(nscmid) + if (nsc .eq. 2*(nsc/2)) then +c +c Even number of slopes in the list, so median is ambiguous +c + if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then +c +c Lower-numbered one is truly less in absolute value, so use it +c + smed=slope(nscmid-1) + else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then +c +c Two slopes are effectively equal. Take the one with sign of the average +c + sum = 0. + do 1 i = 1 , nsc + sum = sum+slope(i) +1 continue + smed = sign(smed,sum) + end if + end if +6 continue + islope(ivx) = nint(0.5*smed*slfac) + if (iabs(islope(ivx)) .gt. 9) + * islope(ivx) = isign(9,islope(ivx)) + else +c +c Forced horizontal beam +c + islope(ivx) = 0 + end if + beta = (sumy-islope(ivx)/slfac*sumx)/nnb +c +c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use +c as is for placing xtup number and/or bracket, then reset it for start of +c actual beam +c + nolev1(ivx) = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + ssq = 0. + syb = 0. +c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) + yb1 = nolev1(ivx) + * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)) + do 4 inb = 1 , nnb + ybeam = yb1+islope(ivx)*xelsk(inb)/slfac +c * -iul*bmhgt*(mult(ivx,ipb(inb))-1) + * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1) + syb = syb+ybeam + ynote = nolev(ivx,ipb(inb)) + off = ybeam-ynote + if (inb .eq. 1) then + off1 = off + else if (inb .eq. nnb) then + off2 = off + end if + ssq = ssq+off*off + smin = min(smin,iul*off) +4 continue + dnolev = 0. + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolevo = nolev1(ivx) + nolev1(ivx) = nint(nolev1(ivx)+iul*deficit) + dnolev = nolev1(ivx)-nolevo + off1 = off1+dnolev + off2 = off2+dnolev + end if + ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2 + if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. + * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax) + * .and. .not.btest(islur(ivx,ipb(1)),2)) then +c +c The first check is to save trouble of putting xtup's in setbm2. +c The penultimate check is that first and last stems aren't both excessive. +c The last check is that a 0 slope has not been forced +c + call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx)) + end if +c +c Check if beam starts or ends too high or low. +c +c xboff = bmhgt*(mult(ivx,ipb(1))-1) + xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1) + l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0. + xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb) + l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0 + if (l1ng .or. l2ng) then +c +c Need to correct start or stop, also slope +c + if (l1ng) then + nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul) + end if + if (l2ng) then + xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul) + end if +c +c Since one or the other end has changed, need to change slope +c + if (.not.btest(islur(ivx,ipb(1)),2)) + * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb)) + end if + if (nssb(ivx) .gt. 0) then +c +c This is a single-slope beam group. Store start heights for later segs. +c + do 3 issbs = 1 , nssb(ivx) + lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac* + * xelsk(lev1ssb(ivx,issbs)) +3 continue + end if + return + end + subroutine sortpoe(nsyst,poe,ipoe) + parameter (nks=125) + real*4 poe(nks) + integer*4 ipoe(nks) +c +c Initialize ipoe: +c + do 3 iord = 1 , nsyst + ipoe(iord) = iord +3 continue +c +c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will +c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. +c + do 4 io1 = 1 , nsyst-1 + do 5 io2 = io1+1 , nsyst + if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then +c +c Interchange the indices +c + itemp = ipoe(io1) + ipoe(io1) = ipoe(io2) + ipoe(io2) = itemp + end if +5 continue +4 continue + return + end + subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 This subr is called ONLY for postscript slurs. +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 + isdat4(nsdat) = 0 + ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur +c +c Get ID code +c + call getchar(lineq,iccount,durq) + if (index('uldtb+-hfnHps ',durq) .gt. 0) then +c +c Null id. Note for ps slurs, 'H' cannot be an ID +c + iccount = iccount-1 + if (lineq(iccount:iccount) .eq. 't') then + idcode = 1 + else + idcode = 32 + end if + else +c +c Set explicit idcode +c + idcode = ichar(durq) + if (lineq(iccount-1:iccount-1) .eq. 't') then +c +c Make t[ID] look like s[ID]t +c + isdat2(nsdat) = ibset(isdat2(nsdat),3) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. +c + if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then +c +c There's a default curvature tweak +c + icurv1 = nint(SlurCurve)+3 + if (icurv1 .eq. 2) icurv1 = 1 + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + end if +c +c Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (durq .eq. 's') then +c +c Endpoint tweaks for linebreak slurs. +c + call getchar(lineq,iccount,durq) ! Must be +|- +c +c Next is vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32) + if (index('+-',dumq) .gt. 0) then +c +c Also a horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64) + end if + iccount = iccount-1 + ilb12 = 1 + go to 1 + else if (index('fnhH',durq).gt.0) then +c +c Special ps slur curvatures. +c Translate to old \midslur args (1,4,5,6) +c + icurv1 = index('fnxhH',durq) + if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + else if (durq .eq. 'p') then ! Local adjustment + call getchar(lineq,iccount,durq) ! +|- + call getchar(lineq,iccount,dumq) ! s|t +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) + if (durq .eq. '+') then + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),26) + else + isdat2(nsdat) = ibset(isdat2(nsdat),28) + end if + else + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),27) + else + isdat2(nsdat) = ibset(isdat2(nsdat),29) + end if + end if + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 +c +c Get id letter +c + if (lineq(iccount:iccount) .eq. 't') then +c +c Old-style t-slur. Use special idcode = 1 +c + idcode = 1 + else + call getchar(lineq,iccount,durq) + if (index('uldtb+-hf ',durq) .gt. 0) then +c +c Null id +c + idcode = 32 + iccount = iccount-1 + else if (durq.eq.'H') then +c +c Postscript slur, cannot use 'H' as code, must check for 2nd 'H' +c + idcode = 32 + iccount = iccount-1 +c +c There may be another "H", but no need to deal with it yet +c + else +c +c Set explicit idcode +c + idcode = ichar(durq) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (index('fhH',durq) .gt. 0) then +c +c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) +c + icurv1 = 2+index('fhH',durq) + if (icurv1 .eq. 3) then + icurv1 = 1 + else if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) +c +c Must change sign if downslur, but cannot do it now since we don't know +c slur direction for sure. +c + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine stop1() + call exit(1) + end + subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink,fontslur + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*79 inameq + character*44 basenameq + character*24 fmtq + character*5 fbarq + character*1 clefq(nm),sq,chax + common /comstart/ facmtr + logical vshrink,lowdot,rename + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) + sq = chax(92) + vshrink = xinstf1.gt.20. .and. .not.novshrinktop + if (vshrink) then + xinsnow = 10. + else + xinsnow = xinstf1 + end if + if (.not.islast) return + write(11,'(a)')'%%%%%%%%%%%%%%%%%' + write(11,'(a)')'%' + write(11,'(a)')'% '//basenameq(1:lbase)//'.tex' + write(11,'(a)')'%' + write(11,'(a)')'%%%%%%%%%%%%%%%%' + write(11,'(a)')sq//'input musixtex' + write(11,'(a)')sq//'input pmx' +c write(11,'(a)')sq//'input musixmad' +c write(11,'(a)')sq//'input musixxad' + write(11,'(a)') + * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%' + if (.not.fontslur) write(11,'(a)')sq//'input musixps' +c +c Need to input musixmad to permit more slurs. +c + if (musicsize .eq. 20) then + write(11,'(a)')sq//'normalmusicsize%' + else if (musicsize .eq. 16) then + write(11,'(a)')sq//'smallmusicsize%' + else if (musicsize .eq. 24) then + write(11,'(a)')sq//'largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterlargefont}%' + else if (musicsize .eq. 29) then + write(11,'(a)')sq//'Largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterLargefont}%' + end if +c +c Set sizes. Have sizes per staff in isize(.) and noinst per staff in +c nsperi(.) +c + iiv = 1 + do 5 iinst = 1 , noinst + if (isize(iiv) .eq. 1) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'smallvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'smallvalue%' + end if + else if (isize(iiv) .eq. 2) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'tinyvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'tinyvalue%' + end if + end if + iiv = iiv+nsperi(iinst) +5 continue +c +c do 5 iiv = 1 , nv +c if (isize(iiv) .eq. 1) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'smallvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'smallvalue%' +c end if +c else if (isize(iiv) .eq. 2) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'tinyvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' +c end if +c end if +c5 continue +c + write(fbarq,'(f5.3)')fbar + write(11,'(a)')sq//'nopagenumbers' + write(11,'(a)')sq//'tracingstats=2'//sq//'relax' + write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt' + write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)') + * sq//'vsize',int(height+.1),'pt' + if (abs(hoffpt) .gt. 0.1) then + if (hoffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'hoffset',nint(hoffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + end if + end if + if (abs(voffpt) .gt. 0.1) then + if (voffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'voffset',nint(voffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + end if + end if +c +c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if +c 3 sharps and treble clef, to avoid vertical clash with top space g# +c + if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)') + * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}' + if (noinst .lt. 10) then + write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + else + write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + end if + iv = 0 + do 1 iinst = 1 , noinst + nstaves = nsperi(iinst) + if (iinst .lt. 10) then + write(11,'(a)')sq//'setstaffs'//chax(48+iinst) + * //chax(48+nstaves) + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}' + * //chax(48+nstaves) + end if + iv = iv+1 + if (nstaves .eq. 1) then + fmtq = chax(48+numclef(clefq(iv))) + lfmtq = 1 + else + fmtq = '{'//chax(48+numclef(clefq(iv))) + lfmtq = 2 + do 2 k = 2 , nstaves + iv = iv+1 + fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv))) + lfmtq = lfmtq+1 +2 continue + fmtq = fmtq(1:lfmtq)//'}' + lfmtq = lfmtq+1 + end if + if (iinst .lt. 10) then + write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq) + else + write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq) + end if + do 3 lname = 79 , 2 , -1 + if (inameq(iinst)(lname:lname) .ne. ' ') go to 4 +3 continue +4 continue + lnam(iinst) = lname + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst, + * '{'//inameq(iinst)(1:lname)//'}' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst, + * '}{'//inameq(iinst)(1:lname)//'}' + end if +1 continue + write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%' + if (EarlyTransOn) + * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn) + call wgmeter(mtrnmp,mtrdnp) + ipi = nint(fracindent*widthpt) + if (ipi .lt. 10) then + write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip' + * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax' + if (.not.vshrink) then + if (xinstf1 .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' + * //sq//'interstaff{',xinstf1,'}'//sq//'relax' + else + write(11,'(a)')sq//'stafftopmarg0pt'// + * sq//'staffbotmarg5'//sq//'Interligne'//sq// + * 'interstaff{10}'//sq//'relax' + end if + if (nv.eq.1) write(11,'(a)')sq//'nostartrule' + write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}' + if (cstuplet) then + write(11,'(a)')sq//'input tuplet' + * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}' + * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}' + * //sq//'/'//sq//'/}}%' + write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet' + * //sq//'let'//sq//'unbkt'//sq//'downtuplet%' + end if + write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq// + * 'addspace'//sq//'afterruleskip%' + return + end + character*1 function udfq(nolev,ncm) +c +c Slur directions +c + common /combc/ bcspec + logical bcspec + ntest = nolev-ncm + if (ntest.lt.0 .or. + * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then + udfq = 'd' + else + udfq = 'u' + end if + return + end + character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv) +c +c Stem direction for single notes +c + character*1 ulfq + character*1 udqqq + logical btest + if (btest(isl,30)) then +c +c Absolute override +c + if (btest(isl,17)) then + udqqq = 'u' + else + udqqq = 'l' + end if + else if (nvmx .eq. 1) then +c +c Single voice per staff, default +c + udqqq = ulfq(1.*nole,ncm) + else +c +c Multi-voice per staff, 1st is lower, 2nd upper +c + if (ivx .le. nv) then + udqqq = 'l' + else + udqqq = 'u' + end if + end if + udqq = udqqq + return + end + character*1 function ulfq(xnolev,ncm) +c +c Stem directions +c + common /combc/ bcspec + logical bcspec + test = xnolev-ncm + if (test.lt.-.001 .or. + * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then + ulfq = 'u' + else + ulfq = 'l' + end if + return + end + function upcaseq(chq) + character*1 chq,upcaseq,chax + if (ichar(chq).ge.61.and.ichar(chq).lt.122) then + upcaseq = chax(ichar(chq)-32) + else + upcaseq = chq + print*,'Warning, upcaseq was called with improper argument: ' + * //chq + stop + end if + return + end + subroutine wgmeter(mtrnmp,mtrdnp) +c +c Writes meter stuff to file 11, so only called if islast=.true. +c + character*1 sq,chax + if (mtrdnp .eq. 0) return + sq=chax(92) + if (mtrnmp.gt.0 .and. mtrnmp.le.9) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i1,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .ge. 10) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i2,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i2,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .lt. 0) then + write(11,'(a26,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfracS{', + * -mtrnmp,'}{',mtrdnp,'}}%' + else if (mtrdnp .le. 4) then + write(11,'(a21,i1,a2)') + * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%' + else if (mtrdnp .eq. 5) then + write(11,'(a)')sq//'generalmeter'//sq//'allabreve%' + else if (mtrdnp .eq. 6) then + write(11,'(a)')sq//'generalmeter'//sq//'meterC%' + else if (mtrdnp .eq. 7) then + write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%' + end if + return + end + subroutine writemidi(jobname,ljob) + parameter(nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + character*1 byteq(4),char,chax + character*10 tempoq,instq + character*44 jobname + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + logical rename + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) +c +c Used to be icmm(0:nm); did midi fail when nv>16? +c + integer*2 iinsiv(nm),icmm(0:15) + character*5 versionc + common /comver/ versionc +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c Can't remember why these were not consecutive. +c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ +c +c Write Header +c + write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6) + * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240) + if (debugmidi) + * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6, + * 0,1,0,numchan+1,0,240 +c +c Write the "conductor" track, for keys, meter, and tempos +c Get the number of bytes in the conductor event stream +c + ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec) + do 15 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec) +15 continue +c ib1 = (4+ljob+26+ndata+4)/256 +c ib0 = 4+ljob+26+ndata+4-256*ib1 + ib1 = (4+ljob+27+ndata+4)/256 + ib0 = 4+ljob+27+ndata+4-256*ib1 + write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0) +c +c Text header +c +c * //char(0)//char(255)//char(1)//char(ljob+26) + * //char(0)//char(255)//char(1)//char(ljob+27) + if (debugmidi) + * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0, + * 0,255,1,ljob+27 + write(51,'(a,$)')jobname(1:ljob) + if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"' +c +c (separate writes are needed to defeat compiler BUG!!!) +c +c write(51,'(a,$)')'.mid, produced by PMX 2.30' + write(51,'(a,$)')'.mid, produced by PMX '//versionc + if (debugmidi) write(52,'(a)') + * '".mid, produced by PMX '//versionc//'"' +c +c Conductor event data: Loop over sections. +c + do 16 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(numchan,isec) + else + mend = imidi(numchan) + end if + do 17 i = msecstrt(numchan,isec) , mend + write(51,'(a,$)')char(mmidi(numchan,i)) + if (debugmidi) write(52,'(z4)')mmidi(numchan,i) +17 continue +16 continue +c +c And close out the time sig / tempo track. +c + write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 +c +c Loop over track for each voice: The following sets up iv. +c + iv = nv + if (twoline(nv)) then + kv = 2 + else + kv = 1 + end if +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 +c + do 5 icm = 0 , numchan-1 +c +c Get the number of bytes in the data stream +c + ndata = 1+imidi(icm)-msecstrt(icm,nmidsec) + do 11 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec) +11 continue +c +cc Add 3 (for instrum) plus 4 (for closing) to byte count, +c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, +c +c ndata = ndata+7 + ndata = ndata+11 +c +c Add 4+lnam(iinsiv(iv)) if lnam>0 , +c + if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv)) +c +c Separate total byte counts into 4 bytes +c + do 2 ibyte = 1 , 4 + if (ndata .gt. 0) then + byteq(ibyte) = char(mod(ndata,256)) + ndata = ishft(ndata,-8) + else + byteq(ibyte) = char(0) + end if +2 continue +c +c Now write front stuff for this track +c + write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1) + * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) + * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm)) + if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm, + * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)), + * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), + * 0,11*16+icmm(icm),10,midbc(icm) + if (lnam(iinsiv(iv)) .gt. 0) then +c +c Add instrument name as sequence name +c + write(51,'(a,$)')char(0)//char(255)//char(3) + * //char(lnam(iinsiv(iv))) + if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv)) + write(51,'(a,$)') + * inameq(iinsiv(iv))(1:lnam(iinsiv(iv))) + if (debugmidi) write(52,'(a)') + * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"' + end if + write(tempoq,'(i2)')icm + write(instq,'(i3)')midinst(iv) + call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3)) +c +c Notes: Loop over sections. +c + do 9 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(icm,isec) + else + mend = imidi(icm) + end if + do 10 i = msecstrt(icm,isec) , mend + write(51,'(a,$)')char(mmidi(icm,i)) + if (debugmidi) write(52,'(z4)')mmidi(icm,i) +10 continue +9 continue +c +c Closing 4 bytes +c + write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 + if (kv .eq. 2) then + kv = 1 + else if (iv .eq. 1) then + go to 5 + else + iv = iv-1 + if (twoline(iv)) kv=2 + end if +5 continue + write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan) + write(15,'(1x,a12,(10i6))') + * 'Bytes used:',(imidi(icm),icm=0,numchan) + close(51) + if (debugmidi) close(52) + return + end + subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag) + parameter(nm=24) + integer*4 iInstTrans(nm),iTransKey(nm) + character*79 notexq + character*1 chax + logical flag +c +c Assumes notexq is blank +c + do 1 i = 1 , nInstTrans + notexq = chax(92)//'setsign' + lnote = 8 + if (iInstTrans(i) .lt. 10) then + notexq = notexq(1:lnote)//chax(48+iInstTrans(i)) + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iInstTrans(i),'}' + lnote = lnote+4 + end if + if (iTransKey(i) .lt. 0) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iTransKey(i),'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+iTransKey(i)) + lnote = lnote+1 + end if + write(11,'(a)')notexq(1:lnote)//'%' +1 continue + flag = .false. + return + end + subroutine writflot(x,notexq,lenline) + character*(*) notexq + if (x .lt. 0.95) then + write(notexq(lenline+1:lenline+2),'(f2.1)')x + lenline = lenline+2 + else if (x .lt. 9.95) then + write(notexq(lenline+1:lenline+3),'(f3.1)')x + lenline = lenline+3 + else + write(notexq(lenline+1:lenline+4),'(f4.1)')x + lenline = lenline+4 + end if + return + end + subroutine wsclef(iv,ninow,clefq,nclef) +c +c Writes \setclef for instrument containing voice iv +c + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + logical rename + character*1 clefq(nm),chax + character*20 temq + if (nclef .lt. 7) then + clefq(iv) = chax(48+nclef) + else + clefq(iv)='9' + end if + if (.not.islast) return + iv1 = 1 + do 1 iinst = 1 , ninow + if (iv .lt. iv1+nspern(iinst)) go to 2 + iv1 = iv1+nspern(iinst) +1 continue + print* + print*,'Should not be here in wsclef!' + call stop1() +2 continue + iv2 = iv1+nspern(iinst)-1 + if (iinst .lt. 10) then + temq = chax(92)//'setclef'//chax(48+iinst) + ltem = 9 + else + write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}' + ltem = 12 + end if + if (iv1 .eq. iv2) then + write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' + else + temq = temq(1:ltem)//'{' + ltem = ltem+1 + do 3 iiv = iv1 , iv2 + temq = temq(1:ltem)//chax(48+numclef(clefq(iiv))) + ltem = ltem+1 +3 continue + write(11,'(a)')temq(1:ltem)//'}%' + end if + return + end diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig b/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig new file mode 100644 index 00000000000..f310e70a83c --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig @@ -0,0 +1,23646 @@ + program pmxab +c +c This program, PMX, developed by Don Simons +c (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with +c MusiXTeX and TeX, its purpose is to allow the user to create high-quality +c typeset musical scores by including a sequence of PMX commands in an ASCII +c input file. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c + character*9 date + character*5 version,versionc + common /comver/ versionc +c +c To compile with gfortran: +c 1. Merge all files using copy *.for epmx[nnnn].for +c 2. Search and replace all character*65536 with character*131072 +c 3. Comment/uncomment getarg lines +c 4. gfortran -O pmx[nnnn].for -o pmxab.exe +c +c To do +c Correct Rainer's email address in manual +c Linesplit (\\) in h +c Tt at start of a movement. +c Toggle midi on or off; allow midi only. +c Page number printed on 1st page even if 1 system. +c Still need inserted space for chordal accidentals +c Voicewise transposition. +c better segno +c coda +c duevolte +c Fix xtup bracket direction in 2-line staves?? (maybe leave as is) +c Sticky ornaments with shifts. +c Deal with Werner's vertical spacing thing associated with title. +c Multiple ties in midi +c Werner's missing c in MIDI due to start/stop ties on same note. +c Beams with single 64ths +c 128ths and/or dotted 64ths +c Close out MIDI with integral # of beats? +c Increase ast dimensions or redo logic. +c Does slur direction get set for user-defined single-note stem dir'ns? +c Transpose by sections. +c Optimization loop over sections only +c Command-line option to read nbarss in. Write out nbarss when optimizing. +c (or just read from .plg?) +c Beams over bar lines. +c 2-digit figures +c A real coule (slanted line between notes in a chord) +c Dotted slurs for grace notes. +c Undotted chord notes with dotted main note. +c Forced line break without line number +c Fix dot moving when 2nds in chord get flipped +c To do: increase length on notexq in dodyn +c 2.618 +c Add option Ac[l,4] to set vert and horiz size and offsets to properly +c center page for letter or a4 paper. +c 2.617 +c In g1etnote, change if-check for note to use index(...) instead +c of ichar(charq) since it was messing up gfortran optimizer +c After pmxa, search for and remove penultimate line / +c because it was screwing up linux-compiled versions +c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) +c 2.616 (111110) +c Allow hairpins to span multiple notes groups (gulps). +c 2.615+ (110810) +c Fix midi when some instruments are transposed, by subtracting +c iTransAmt(instno(iv)) from pitch values sent to via addmidi in +c make2bar.for (for main notes) and docrd (for chord notes) +c 2.615 (110725) +c Fig bug with size-setting (in topfile) when instrument has >1 staves +c 2.615 (110724) +c Make AS[0|-|s|t]... really set sizes +c 2.614 +c Mod notex.for to fix Terry's bug with raised dotted rests (caused +c by double-hboxing). +c 2.613 +c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. +c 2.612 +c Enhance AS to allow s or t for smallsize or tinysize +c 2.611 +c Error trap for "D" before any notes in a block. +c 2.610 +c Instrument-wise key changes and transposition (incomplete) +c 2.603 +c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors +c following reading in an include file. +c 101121 Added some error messages in g1etset.for setup data +c 2.602 +c Correct slur indexing in linebreakslurs. +c Account for comment lines in line count for error messages +c 2.601 +c Bug fix: allow 24 slurs with graces +c 2.60 Changes made make it really big +c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o +c major reprogramming, and 16 may also be a problem (icmm) +c nm=24 (voices) done +c 24 slurs done +c 24 simultaneous beams (Replace index 24 by 0, so get 0-23) +c bufq*131072 (gfortran only) +c getarg syntax (gfortran only) +c 2.523+ +c Fix voice numbering for normal dynamics and text dynamics +c 2.523 +c Version of bigpmx first posted to Hiroaki's web site. +c 2.522 +c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. +c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. +c 5/13/10 Fix log2 function +c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. +c 2.521+ +c 091025 Enable dotting 2nd part of linebreak slur or tie. +c To adjust barno height due to linebreak slur, use \bnrs instead of +c explicitly redefining \raisebarno (pmxb) +c 2.521 +c Bugfix +c 2.520 +c 090519 Enable ligfonts (special figured bass characters) +c 2.519 +c Fix another bug which kept \sk from being output so misaligned some notes. +c 2.518 +c Fix bugs: referencing fig data, char declaration for member of +c common/comfig/ +c 2.517 +c Allow figures in voice 1 + any one other. +c 2.516 +c Allow figures in voice #2 +c 2.515+ to do: Change manual and activate rule against clef change in voice #2. +c 2.515 +c 071222 Changes in getnote to allow auto forced beams to start anywhere. +c 071206 In make2bar, shift fermataup7 to left over centered pause. +c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line +c staff (it was screwing up vertical justification). +c n34 for tweaks to midi durations of quarter note septuplets. +c To do: In ref250.tex, the tables where 's,t,)' is explained, the line +c [+,- i] ... Vertical adjustment of the start of second segment +c should it be replaced by +c [s +,- i] ... Vertical adjustment of the start of second segment +c 2.514 +c Changes in make2bar to get horizontal spacing right when normal grace +c follows after grace +c Changes in dograce to get octaves right for any material entered inside +c \gaft, which shields transpose register changes from the outside world. +c 2.513 +c In make1bar, near end, for forced beams starting with a rest, copy hgt and +c slope tweaks to ALL notes after first, not just the second one, so if +c there's more than one rest at start the tweaks are still observed. +c In beamid and beamend, add stand-alone triply-flagged notes for xtups. +c 2.512 +c Near end of pmxb, fix error trap to allow redundant 'RD' +c Enable multiplicity down-up '][' within xtup. +c 2.511 +c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by +c adjusteskz as in bar 7 of barsant. +c 2.510a +c Test: remove restriction on tempo changes in MIDI macros +c Send to CM for beta testing. +c 2.509+ +c To do: Correct manual on AS. "-" is for smaller staves. +c 2.510 +c Forgot to declare litq, voltxtq as character in subroutine getgrace +c 2.509 +c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) +c 2.508 +c Allow graces in xtups. New subroutine getgrace. +c 2.507 +c To do: Raise/lower figures. +c To do: Add 24, 29 to list of musicsizes in manual +c New sub adjusteskz to account for ask's when computing lengths of +c brackets for unbeamed xtups, slopes and horizontal posn's of number +c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags +c Add look-left option for keyboard rests, "L" in rest command, set iornq(30) +c 2.506 +c Fix bug with AK, when simultaneous rests have same duration, use defaults. +c 2.505 +c Keyboard rests AK +c 2.504 +c Space after normal grace: option X[n] +c Fixed og when nv .ne. noinst, by using sepsymq instead of '&' +c (To do) length of xtup bracket when there is added non-collision space. +c Trap musicsize if .ne. 16,20,24,29. +c 2.503 +c Enable arpeggio left shift with ?-x +c To do: In manual, arpeggio over 2 staves. +c Allow musicsize of 24 and 29. Had to define meter font size explicitly, +c also change font size for text dynamics, but not much else so far. +c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn +c was called, causing error in printing replacement number. +c 2.502 +c Incorporate Dirk Laurie's patch to use { , } , for ties. +c Figure height adjustment: append +[n] +c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) +c 2.501 +c Readjust horizontal offset back to .8 in LineBreakTies +c Fix zero-subscript (iudorn) in putorn +c 2.50 +c Increase number of text-dynamics (dimension of txtdynq) per block +c from 12 to 41. +c Slur option n to override altered default curvature. +c Allow default ps slur curvature tweaks with Ap+/-c +c 2.416 +c Increase length of textdynq from 24 to 128 +c (Todo) Add comment in manual about blank lines at end. +c Configuration file: Define subroutine getpmxmod, check path in environment +c variable pmxmoddir, check existence, read lines into bufq after setup. +c Increase dimension on idynn in dodyn from 4 to 10 for max number +c of marks in a bar +c Increase allowable # of lines from 2000 to 4000. +c (To do) Replace definition of \liftpausc per Olivier. +c (To do) Fix extraneous error message if RD is placed at very end. +c 2.415 +c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt +c instead of redefining \xnum. Change font used to \smallfont (as for +c normal xtups, +c Allow slur to start on rest. +c 2.414 +c Correct bug in crdacc when adding accidental to boundary causes number of +c segments to decrease +c Special rule for 3-accidental chords: If no 2nds, place them in order +c top, bottom, middle. +c 2.413 +c Correct bugs in chordal accidentals, related to left-shifted noteheads +c (a) Special problems with downstem when main note needs shifting +c (b) Assign 0 rank to boundary segs due to left-shifted noteheads +c 2.412 +c Change default horiz shift of start of seg 2 of linebreak slurs: +c -.7 for slurs, -1.2 for ties, +c Use height of start of seg 1 slur itself for end of 1 and start of 2. +c 2.411 +c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. +c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end +c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. +c With "Apl", curvature adjustments on starting slur command apply to seg 1, +c those on ending command to seg 2. +c 2.410 +c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine +c \xnum, \unbkt, \ovbkt. +c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is +c flag, mult(5-9) is tweak value+16 +c 2.409 +c Bugfix in docrd for MIDI: Use original pitch in case main/chord were +c switched due to 2nds. +c Remove "o" from error message for "A" command. +c New syntax: optional instrument number separator ":" in movement +c break command to precede a 2-digit instrument. +c Conditional output formats for \setname at movement break to allow +c instrument numbers >9. +c Bugfix in coding to raise barno due to slur over line break (pmxb) +c Move date/version data statement in pmxab to a better place. +c 2.408 +c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). +c Bug fix in \liftPAusep in notex.for and in pmx.tex +c Character variables for version and date +c For up-stem single graces slurred to down-stem, shift slur start left by +c 0.8 so slur doesn't get too short. +c Initialize and slide mult, same as other full-program variables in /all/. +c 2.407 +c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, +c 2.406 +c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing +c equalization). +c Put dimensions of double sharps and flats in crdacc (for chords). +c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' +c Use only first 4 bits of mult for multiplicity+8, so rest can be used +c for other stuff. +c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. +c 2.405: Not published but saved for safety. +c Option Aph to write \special{header=psslurs.pro} top of each page, so +c dviselec will work OK. +c 2.404 +c Allow slur to end on rest, but not start on a rest. Efaults height +c of ending is default height of start (before any automatic or user- +c defined djustments). User may adjust height as normal from default. +c 2.403 +c Bugfix: turn off repeated beaming patterns.at end of non-last voice. +c 2.402 +c Automatic repeated forced beams. Start with "[:" End with next explicit +c forced beam or end of input block. +c Increase # of forced beams per line of music per input block from 20 to 40 +c 2.401 +c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. +c Makes 1st part normal shape, and starts 2nd part a little further left. +c Enable arpeggios in xtuplets. Had to make time itar(narp) a real. +c 2.40 +c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. +c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse +c sign for down-slurs. +c 2.359 +c Add error exit subroutine stop1 to make exit status g77-compatible.. +c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote +c Fermata on vertically shifted rest: special trap in putorn() to set height. +c Correct multiple grace note spacing for small staves (in dograce, +c define wheadpt1 depending on staff size) +c 2.358 +c Allow curvature corrections at start of postscript slur, in dopsslur() +c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust +c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] +c Make t[ID] act like s[ID]t, most mods in spsslur(). +c Add spsslur() to read in data for ps slurs, call from getnote. +c In beamstrt, save args for SetupB in common comipb to save them for +c 2nd call when xtup starts with rest +c Add spacing for ornament ")" as if it were accidental, in make2bar(). +c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() +c Horiz. shift start of ps grace slur, 2 places in dograce(). +c Horiz shift end of grace slur in endslur() +c Make st slurs into postscript ties. Separate subroutine dopsslur(), +c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) +c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. +c 2.357a +c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote +c 2.357 +c Increase dimension for # of lit TeX strings from 52 to 83. +c Allow blank rest in middle of xtuplet. Only mods in g*etnote(). +c 2.356 +c Increased some dimensions from 30 to 40 to allow up to 40 pages. +c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). +c Fix parsing of "f,h,H,HH" in sslur. +c Fix bug with cdot, note-level for slur termination (in getnote) +c 2.355 +c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], +c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues +c Make midi recognize ps ties in doslur. +c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote +c to get octave right. +c 2.354 +c With postscript slurs, make t-slurs real ties by inserting replacement +c macros \tieforisu, etc, defined in pmx.tex +c Check for open cresc or decresc at end of input block, using list[de]cresc +c Hairpin syntax conditional on postscript slurs. Backup to fill in start +c level, using new backfill(...). Separate height tweaks for +c start and finish. +c 2.353 +c K-0+n to transpose by half step (rather than just change key) +c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of +c \mbrest's +c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end +c of input block before movement break, and at start of block after +c movement break, using \newmovement rather than \setzalaligne, since +c former already redefines \stoppiece. In second case, set rptfg2='z'. +c Make clefq(nm) common between pmxb and getnote; change references in +c getnote at 'M' to array elements, setting all new clefs as you go. +c 2.352 +c Remove \parskip redefinition from pmx.tex; write it into TeX file when +c "Ae" is invoked. +c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine +c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', +c translate them thru mapping to (1,4,5,6) as \midslur params, then let +c \psforts translate them back to ps slur macors. +c 2.351 +c Number slurs from 0 up instead of 11 down, anticipating postscript slurs. +c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. +c Increase length of basenameq to 44 characters everywhere. +c Increase dimension of mcpitch (midi-chord-pitch) to 20. +c Set default systems per page to 1 if nv>7 +c In pmxb, move place where isystpg is reset to 0, so that \eject gets +c written when there is just one system per page. +c 2.35 +c Cautionary accidentals with 'c' anywhere in note symbol. +c NEW pmx.tex with \resetsize to set size to normal or small depending on +c current \internote. Used with new coding in dograce() to get right +c new size in case user has \setsize'ed some lines to \smallvalue. For +c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. +c Affects pmx.tex. +c Continuation figure with fractional length. May now mix with other figures. +c If another figure follow Cont-fig, separate with colon. +c 2.342 +c Bugfix in getnote to recognize relative octave shift in grace at start of +c input block. +c In make2bar, initialize islhgt=0 earlier than before (possible solution +c to Suse g77 compile problem that I could not reproduce).. +c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d +c 2.341 +c Syntax check: Forced page break page number must be > than previous. +c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. +c 2.34 +c New pmx.tex with redefined liftpausc +c Bug fix with dotted, non-beamed xtups. +c 2.332 +c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. +c Allow arbitrary pos. input to W in g1etnote and getnote. +c 2.331 +c Bug-fix in dodyn(..): typo on length of arg of txtdyn +c 2.33 +c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() +c 2.321 +c Rescale accidental shifts. Still use 7 bits but now map (0,127) +c onto (-1.,5.35) +c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups +c 2.32 (Noticed after posting) +c Prohibit "/" as figure. +c 2.32 (Posted) +c Tidied up accidentals in chords, do spacing. +c Still to do: +c check for "(" on chord notes in spacing algo +c small accids +c double accids +c autoshift slurs +c 2.310 +c Extra call to precrd ahead of spacing chk, and single-note crd/acc +c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. +c 2.309 +c Alternate algo for accid shifts in chords. +c 2.308 +c Auto horiz. notehead shifting added to precrd. +c 2.307 +c Auto shifting of multiple accidentals in chords. +c "Ao" in main chord note to keep accidentals in order. Set nacc(28). +c If there are any manual main or chord note shifts, then +c If any manual shift is preceded by "A" then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, +c End if +c End if +c 2.306 +c Initialize legacy note level to middle C in case user forgets to set +c octave. +c Shift xtup note? +c Shift in elemskips rather than noteheads? +c 2.305 +c Stop pmxb from multiple endvolta's at start of new page. +c 2.304 +c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on +c for multiple notes in the voice, "S:" last shortened note. +c 2.303 +c vshrink stuff all OK? Description is in pmxb. +c 2.302 +c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff +c hits 20. This still needs work. +c Add " /" to last line if last char is not % or /. +c 2.301 +c Check in beamn1 for single note before multiplicity down-up. +c allow '.PMX' as well as '.pmx' +c 2.299 +c Correct typo in pmxb involving PMXbarnotrue. +c Replacement printed number for xtup: Unsigned integer after 'n' after 'x' +c Minor upgrade parsing xtuplet options 'x...' +c Correct dimension of nxtinbm in make2bar. +c 2.298 +c Account for doubled xtup notes in subroutine getx (user-defined spaces), +c by adding ndoub as an argument.. +c 2.297 +c Created and solved compiler problem. Put drawbm(NM) in its own common. +c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar +c when \centerbar is used. +c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX +c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. +c 2.296 +c Correct printed numbers for forced beams with multiple xtups. For each beam +c make list in setupb by voice of eloff (h-offset) and mtupv (printed #) +c Increase lengths of jobname and infileq by 20 characters +c Enable whole notes and breves as 1st or last note of xtup in beamn1 and +c beamend, and wholes in beamid. +c 2.295 +c Midi balance Ib[n1]:[n2]:...[nn] +c Single-slope beam groups [...]-[...] +c Trap "i" unless after accidental (main notes, xtups, chord notes) +c 2.294 +c Unequal xtups with "D" to double a note in an xtup. +c As above, "F" will (a) increase multiplicity by 1 for marked note and next +c one and (b) add a dot to the first one. +c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on +c when "." is encountered, then correcting beam start time.(end of getnote) +c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... +c 2.293 +c Check for single notes spanning bar lines. +c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup +c must be set in make2bar since beamstrt is not called, fixing problem with +c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix +c problem when >2 staves. +c Add nodur to args of dodyn, so can check if stemless and avoid height tweak +c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak +c 2.292a +c Undo syntax check for Type 2 or 3 TeX string starting in column 1. +c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! +c 2.292 +c Allow comments in xtuplets +c Enable multiple octave jumps in grace notes. +c Allow dynamics in xtuplets. +c Fix bug in getdyn searching for end of text string (correct length of lineq +c to 128) +c Fix bug in dodyn, must ignore horiz. interaction tweak for +c user-text (idno = 0) +c Syntax check for Type 2 or 3 TeX string starting in column 1 +c (NOTE: later undone!) +c Syntax check for page number > npages at forced line break. +c 2.291 +c Fix error in AS command (accid spacing for small systems), making only +c one spec per staff, nv total. +c Stop using MIDI channel 10 +c 2.29 +c Fix error in console output format for # of bytes used in MIDI file. +c Fix bug in dograce so no space is added between grace and main note when +c there is a MIDI-only accidental. +c Fix bug so oes?+4 works. It was too ugly to explain. +c ...Different ways of storing accidental specs on input and output. +c No longer zap \writezbarno in special situations. +c Fix bug in dyntxt level on rest +c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. +c Activate with Ae. (Maybe later could input alternate values for +c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 +c in the page, and \endeq on 1st note of next-to-last line in page. +c 2.28 +c Flip direction of forced beam "[f..." +c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) +c Fix bug in sliding ip's for txtdyn's +c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) +c 2.27 +c Comment out lines in dodyn checking number of dynamic marks found. Voice +c order may not be monotonic if two lines on a staff. +c Literal dynamic: D"[text]" +c 2.26 +c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, +c increasing dimension of idynn to 4 to allow 4 symbols on same note. +c Increase voltxtq length from 10 to 20. +c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough +c accounting for ast's is done by defining effective headwidth +c whead1 in makebar2 to be 0.8*whead. +c 2.25 +c Fix logic bug with sepsym's when # of instruments changes. +c Slight increases in default offsets for hairpin starts after "p" +c 2.24 +c Hairpins D< or D> as toggle. +c Many automatic position tweaks for letter-group dynamics and hairpins. +c 2.23 +c Continued rhythmic shortcuts: space followed by "." or "," +c 2.22 +c In call to doslur, change tno(...) to tnote(...). This was only +c used when checking to slurs per stem directions, and should have been +c the note duration all along. +c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. +c Use "i" anywhere in note symbol. +c 2.21 +c Increase from 20 to 30 dimensions for movement breaks and midi sections. +c Fix out-of-order declarations per mutex comments +c Add "Bad error" and "Kluging" messages to log file. +c 2.197 +c add /comips/ to save tie-check midi variables +c For spacing of clef changes at start of input block, changed integer time +c lastnodur to prevtn, so it works with xtups. Possible incompatibility! +c 2.196 +c Fix Ickbug with time check in ncmid() +c Interchange \fermataup7 and \pausec to get proper alignment +c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. +c Add defn's of \hsp, \hspp to pmx.tex +c Fix pre-slurs on xtup chord notes. +c Fixed raised PAuse, define \liftPAuse +c Replace \zbreve\sk with \breve. +c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what +c about "o" and 1 as shorthand for 16???? Search for "Kluge" +c Added "vo" (voice) as MIDI instrument 55 +c Allow 3-digit page numbers (search for "toppageno") +c Fix bug caused by prior fix (cancelling accid after bar line was ignored). +c Fix double accids in chords +c 2.194 +c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if +c block. +c Add meter to MIDI file with every pause +c Purify FORTRAN? +c 2.193 +c Increased # of in-line TeX strings from 36 to 52. +c Fix entry of # of bytes in header of tempo/meter/key track to allow >255. +c 2.191 +c Event track: Tempos, meters, keys all together. Data in comevent +c 2.15 +c Pretty good midi capability. Still no attention to slurs on chord notes. +c 2.11 +c 11 Dec 99 c rm1 +c 11 Dec 99 "oes?", "oe?" +c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes +c 11 Dec 99 Error message for shifted, repeated ornaments. +c 2.10 (Version 2.1) +c Fix bug with lowdot and xtuplets +c 2.09 +c Fix bug with multiple ornament heights over beams, when one is . or _ +c Error message from pmxa if rest on last note of xtup. +c Enable 12 slurs. +c Reinstate multiple rests at start of xtup. +c 2.07 +c Combine consecutive type-1 TeX strings. +c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. +c Fixed breve chord notes in docrd +c Check irest(28) as well as vxtup when setting nodur for chord notes, since +c vxtup isn't set until 1st *main* note in xtup +c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. +c 2.06+ +c Make deterministic the beam slope calculation when there are an even # of +c slopes in list and middle two are equal magnitude but opposite sign. +c pmxa Trap for "o:" before 1st note in block +c Partial bug fix for 64th notes in xtuplets. +c Make ixrest a vector, since with new time scheme may not finish xtup in +c same notes block. +c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) +c 2.06 +c Account for changes in nv when computing \interstaff. Add a counter +c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever +c setting isysflb(iflb). Note nv can only change at a forced line break. +c Note also, iflb starts at 0! +c 2.05 +c Automatic start of new notes group with part 2 of staff-jump beam +c In make1bar, set irest bit 29 of lowest-voice note at same time, +c use as flag when making notes groups. +c For now, remove dummy blank line at end...it zaps terminal repeats. +c 2.02 +c Fixed slur-counting bug for multiple, slurred, aftergraces. +c 2.01 +c Increase to ask(1400) +c Increase max forced page breaks to 18 +c Define pausc for centered pause +c 2.0a +c Insert dummy blank line at very end to handle input files w/o terminal CR-LF +c pmx03r +c Option m[n] in S symbol to change musicsize (for parts) +c Double dotted rests now work. +c Write file name to log file +c Check existence of input file +c Allow 24-char jobname, may end with ".pmx" +c Comment out time stuff +c Replace 3-argument getarg with 2-argument + iargc +c Fix bug with negative noinst due to nint<=int replacement +c move lovation of iv in isdat1 to allow iv>7. +c Set nm=12 +c pmx03q +c replace int(x+.001) with nint(x) +c Write TeX file name to screen and to pml. +c Replace char(...) with chax(...) to sovle msdev bug. +c Bug fix: macro terminations when M is on a line by itself. +c Bug fix: don't accumulate space for XS in pmxa. +c Streamline Macros: use pointers to bufq instead of scratch files +c pmx03p +c Store input file in single character array bufq. +c lbuf(i)*2 is length of line i +c ipbuf is position just before next line to be read. +c pmx03 +c Optimize read/writes +c pmx02 +c Fix line count (for errors) when there are saved macros +c pmx01 +c In optimize mode, open/close macros (Watch out for residual zz files!) +c Command line input +c Option Ao to optimize, otherwise normal processing +c +ccccccc + parameter (nks=125,nm=24,mv=24576,maxblks=4000) + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /comevent/ miditime,lasttime + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + common /commus/ musize,whead20 + integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks) + real*4 poe0(nks),poe(nks) + logical isfirst,optimize + logical*4 fexist + character*44 jobname + character*47 infileq + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * idum,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + logical rest,firstline,newmeter + common /comdiag/ n69(0:nm),n34(0:nm) + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + common /truelinecount/ linewcom(20000) +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c +ccccccccccccccccccccccccc +c + data date /'19 Mar 12'/ + data version /'2618'/ +c +ccccccccccccccccccccccccc + data maxit,ncalls /200,0/ + data isfirst /.true./ +c itstart = mytime() + versionc = version +c +c Initialize midi parameters +c + gottempo = .false. + ismidi = .false. + debugmidi = .false. + relacc = .false. + mmacrec = .false. + nmidsec = 1 + mgap = 10 + miditime = 0 + lasttime = 0 + nmidcrd = 0 + nusebl = 0 + notmain = .false. + do 3 ivx = 1 , nm + twoline(ivx) = .false. + midinst(ivx) = 6 + midivel(ivx) = 127 + midibal(ivx) = 64 + miditran(ivx) = 0 +3 continue + do 12 icm = 0 , nm + imidi(icm) = 0 + restpend(icm) = .false. + trest(icm) = 0. + levson(icm) = 0 + levsoff(icm) = 0 + slmon(icm) = .false. + naccbl(icm) = 0 + n69(icm) = 0 + n34(icm) = 0 + msecstrt(icm,1) = 1 +12 continue +c +c End of midi parameter initialization +c + musize = 0 + optimize = .false. + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else + call getarg(1,jobname,idum) ! May need to replace this w/ next line +c call getarg(1,jobname) + end if +10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then + print*,'Jobname is too long. Try again.' + call stop1() + else if (ljob .eq. 0) then + print*,'No was jobname entered. Try again.' + call stop1() + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. + call getarg(2,jobname,idum) ! May need to replace this w/ next line +c call getarg(2,jobname) + numargs = 1 + go to 10 + else + print*,'Illegal option on command line' + call stop1() + end if + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + call stop1() + else + infileq = jobname(1:ljob)//'.PMX' + end if + end if +c +c Open a log file +c + open(15,file=jobname(1:ljob)//'.pml') + call printl('This is PMX, Version '//version//', '//date) + ljob4 = ljob + call printl('Opening '//infileq) + open(18,file=infileq) +c +c Copy input file into common buffer +c + ipbuf = 0 + linewcom(1) = 1 + do 8 ilbuf = 1 , maxblks + ncomments = 0 +14 read(18,'(a)',end=9)lnholdq + lbuf(ilbuf) = lenstr(lnholdq,128) + if (lbuf(ilbuf) .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lbuf(ilbuf) = 1 + lnholdq = ' ' + end if +c +c Now line has at least one non blank character. Check for comment +c As of Version 260, do not copy comments into bufq +c But need to count %'s for error messaging +c if (lnholdq(1:1).eq.'%') go to 14 + if (lnholdq(1:1).eq.'%') then + ncomments = ncomments+1 + go to 14 + end if +c +c When here, have counted all preceding comments and have a real line +c + if (ilbuf .gt. 1) then + linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments + else + linewcom(1) = 1+ncomments + end if + if (ipbuf+lbuf(ilbuf).gt.65536) then + print*,'Too many characters in file, stopping' + call stop1() + end if + bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq + ipbuf = ipbuf+lbuf(ilbuf) +8 continue + call printl('Too many lines in input file') + call stop1() +9 continue +c +c Insert dummy line to handle input files w/o CR-LF at end. +c + nlbuf = ilbuf-1 +c nlbuf = ilbuf +c bufq(ipbuf+1:ipbuf+3) = ' / ' +c lbuf(nlbuf) = 3 + close(18) + do 6 numit = 1 , maxit + if (optimize) call printl('Starting an iteration') +c +c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. +c Otherwise, nbars0 is the input +c When islast=.false., pmxb only returns poe's, otherwise does whole job +c + call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize) + if (.not.optimize) then + if (ismidi) then +c +c Set up channel numbers for midi. +c + numchan = 0 + do 11 iv = nv , 1 , -1 + if (twoline(iv)) then + midchan(iv,2) = numchan + numchan = numchan+1 + end if + midchan(iv,1) = numchan + numchan = numchan+1 +11 continue +c +c numchan will now be the number of channels, but max channel # is numchan-1 +c +c Set up velocities, balances, and midi-transpositions +c + do 13 iv = nv , 1 , -1 + if (twoline(iv)) then + midvelc(midchan(iv,2)) = midivel(iv) + midbc(midchan(iv,2)) = midibal(iv) + midtc(midchan(iv,2)) = miditran(iv) + end if + midvelc(midchan(iv,1)) = midivel(iv) + midbc(midchan(iv,1)) = midibal(iv) + midtc(midchan(iv,1)) = miditran(iv) +13 continue + end if +c +c TEMPORARY!!! +c + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + do 10000 ilb = 1 , nlbuf +c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), +c * bufq(ip1:ip1+lbuf(ilb)-1), +c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), +c * k=min(3,lbuf(ilb)),1,-1) + ip1 = ip1+lbuf(ilb) +10000 continue + iplast = ip1-1 +c +c Check to see if (1) last line is "/" and (2) next to last +c line is "/" +c +c print*,'iplast:',iplast +c print*,'Last line:' +c print*,bufq(iplast+1-lbuf(nlbuf):iplast) +c print*,'Last char of next to last line:' +c print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) + if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then + if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then + print*,'Removing last line of "/"' + write(15,*)'Removing last line of "/"' + nlbuf = nlbuf-1 + end if + end if +c + call pmxb(.true.,poe0,ncalls,optimize) + if (ismidi) then +c +c Write midi file +c + open(51,file=jobname(1:ljob)//'.mid') + if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm') + call printl(' ') + call printl('Writing '//jobname(1:ljob)//'.mid') + call writemidi(jobname,ljob) + end if + close(15) + stop + end if + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + call pmxb(.false.,poe0,ncalls,optimize) + call poestats(nsyst,poe0,poebar0,devnorm0) +c +c Save initial deviation and line breaks for later comparison +c + if (numit .eq. 1) then + devpmx = devnorm0 + do 20 isys = 1 , nsyst + nbari(isys) = nbars0(isys) +20 continue + end if + call sortpoe(nsyst,poe0,ipoe) + do 1 iupord = nsyst , 1 , -1 + isysu = ipoe(iupord) + print*,'isysu=',isysu + write(15,*)'isysu=',isysu +c +c Skip if system isysu has poe0 < avg or isysd has poe0 > avg +c + if (poe0(isysu).lt.poebar0) go to 1 + do 5 idnord = 1 , nsyst + isysd = ipoe(idnord) + if (isysu.eq.isysd .or. nbars0(isysd).eq.1 + * .or. poe0(isysd).gt.poebar0) go to 5 + do 2 isyst = 1 , nsyst + nbars(isyst) = nbars0(isyst) + if (isyst .eq. isysu) then + nbars(isyst) = nbars(isyst)+1 + else if (isyst .eq. isysd) then + nbars(isyst) = nbars(isyst)-1 + end if +2 continue + call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize) + call pmxb(.false.,poe,ncalls,optimize) + call poestats(nsyst,poe,poebar,devnorm) + if (devnorm .lt. devnorm0) then + devnorm0 = devnorm + poebar0 = poebar + do 4 isys = 1 , nsyst + nbars0(isys) = nbars(isys) + poe0(isys) = poe(isys) +4 continue + print*,'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(15,*)'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call sortpoe(nsyst,poe0,ipoe) + go to 6 + end if +5 continue +1 continue +c +c If we get here, must have gone thru all switches and found nothing better, +c so done! +c + go to 7 +6 continue +7 continue + print*,'Optimum located, numit:',numit,', ncalls:',ncalls + write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls + print*,'Final error:',devnorm0,', initial error:',devpmx + write(15,*)'Final error:',devnorm0,', initial error:',devpmx + print*,'Percentage improvement:',100.*(1-devnorm0/devpmx) + write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx) + call printl('Initial bars/system:') + write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + call printl('Final bars/system:') + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize) + call pmxb(.true.,poe0,ncalls,optimize) +c itend = mytime() +c print*,'Elapsed time in ms:',itend-itstart +c write(15,*)'Elapsed time in ms:',itend-itstart + close(15) + end + subroutine accsym(nacc,acsymq,lacc) + character*3 acsymq + iacc = iand(nacc,7) + if (iacc .eq. 1) then + acsymq = 'fl' + lacc = 2 + else if (iacc .eq. 2) then + acsymq = 'sh' + lacc = 2 + else if (iacc .eq. 3) then + acsymq = 'na' + lacc = 2 + else if (iacc .eq. 5) then + acsymq = 'dfl' + lacc = 3 + else if (iacc .eq. 6) then + acsymq = 'dsh' + lacc = 3 + else + print*,'bad accidental: ',iacc + end if + return + end + subroutine addask(taskn,waskn,elaskn, + * fixednew,scaldold,tglp1,isudsp) + parameter (nm=24) + logical isudsp + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comtol/ tol + if (isudsp) then +c +c Find which udsp we're dealing with +c + do 1 iudsp = 1 , nudsp + if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2 +1 continue + print*,'You should note BEEE here in addask!' + call stop1() +2 continue +c +c Fixednew and scaldold must not be changed, since udsp's are already included +c in fsyst from pmxa, and udsp don't involve scaled space.. +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c Must add user-defined space to what's there already. +c + wask(naskb) = wask(naskb)+udsp(iudsp) + else +c +c This place has no other space. +c + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = udsp(iudsp) + elask(naskb) = 0. + end if + else +c +c This is a normal space, no effect if smaller than existing space +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c We already put in some space at this time +c Check if new one needs more space than old one at same time +c + if (waskn .gt. wask(naskb)) then + naskb = naskb-1 + else + return + end if + end if + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = waskn + elask(naskb) = elaskn + fixednew = fixednew+waskn + scaldold = scaldold+elaskn + end if + return + end + subroutine addblank(noteq,lnoten) + character*8 noteq + character*1 tchar + tchar = noteq + noteq = ' '//tchar + lnoten = 2 + return + end + subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd) + parameter (nm=24) + integer nfb(nm) + common /comtol/ tol + real*4 t1fb(nm,20),t2fb(nm,20) + character*1 ulfbq(nm,20) + ifbadd = 1 + nfb(iv) = nfb(iv)+1 + do 1 ifb = nfb(iv)-1 , 1 , -1 + if (tnew .lt. t1fb(iv,ifb)-tol) then + t1fb(iv,ifb+1) = t1fb(iv,ifb) + t2fb(iv,ifb+1) = t2fb(iv,ifb) + ulfbq(iv,ifb+1) = ulfbq(iv,ifb) + else + ifbadd = ifb+1 + go to 2 + end if +1 continue +2 continue + t1fb(iv,ifbadd) = tnew + ulfbq(iv,ifbadd) = 'x' + return + end +c +c + subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) + parameter(nm=24,mv=24576) + integer*2 mmidi,itk(25) + integer*4 itiesav(5,100) + character*1 notenumq + logical endrest,eximacc,it1found + logical rest + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Following variables are local but must be saved. I hope they are. +c (3/18/00) With g77 they are not, so add a common block here. +c +c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) + integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15) + common /comips/ ipslon,lusebl,jusebl +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c +c Cancel out barline accidentals if there's a rest. +c + if (rest) naccbl(icm) = 0 +c +c Special path to insert dummy rest at end of a section +c + if (endrest) go to 20 +c + do 7 ion = 0 , nmidcrd +c +c check if this is only to get pitch of a chord note +c + if (notmain) go to 6 +c +c check for rest +c + if (rest) then +c +c Will not put in a note, but must update timing +c + if (.not.restpend(icm)) then +c +c First rest in sequence, save the time +c + restpend(icm) = .true. + trest(icm) = time + else + trest(icm) = trest(icm)+time + end if +c +c Note: code checkers don't like the above due to calling addmidi(trest(icm)) +c but this only happens if rest at end of section (endrest=.true.) (called +c from getmidi(), in which case these above lines are bypassed. +c + call chkimidi(icm) + return + end if +c +c time tics +c + if (imidi(icm).gt.0 .and. ion.eq.0) then + idur = mgap + else + idur = 0 + end if + if (restpend(icm)) then + restpend(icm) = .false. + idur = idur+nint(15*trest(icm)) + end if +c +c time to start of note +c + idurvar = isetvarlen(idur,nby2on) + if (nby2on .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + do 2 i = 1 , nby2on +c +c imidi points to cell before highest (leftmost) byte. Start with lowest byte +c at far right, fill in backwards +c + mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256) + if (nby2on .gt. 1) idurvar = idurvar/256 +2 continue + imidi(icm) = imidi(icm)+nby2on-1 +c +c Note-on signal +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 9*16+icm + mmidi(icm,imidi(icm)) = 9*16+icmm(icm) +c +c Entry point for chord note pitch determination +c +6 continue +c +c Get midi pitch. On chord iteration, only do this first time (main note), +c since pitch was already computed for nonmain chord notes. +c + if (ion .eq. 0) then + ipsav = nolev*12./7+11 + ipsav0 = ipsav + if (isig .ne. 0) then +c +c Adjust for signature +c + notenumq = char(48+mod(nolev,7)) + if (isig.ge.index('4152630',notenumq)) then + ipsav = ipsav+1 + else if (-isig.ge.index('0362514',notenumq)) then + ipsav = ipsav-1 + end if + end if +c +c Deal with accidentals. +c +c iacc 0 1 2 3 4 5 6 7 +c effect X fl sh na X dfl dsh X +c iashft X -1 1 0 X -2 2 X +c + jacc = 0 + eximacc = .false. + if (iacc .gt. 0) then +c +c Adjust key-sig-adjusted pitch for explicit accidental (and exit) +c + jacc = iashft(iacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav +c +c (Above) Shift applies to diatonic pitch but will be added to adjusted one +c + else if (naccim(icm) .gt. 0) then +c +c Possible implicit accidental from earlier in the bar +c Check for prior accid in this bar at this note level +c + do 3 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + jacc = jaccim(icm,kacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 4 + end if +3 continue +4 continue + end if +c +c Must split off the following if block from those above because chord +c notes can cause naccim>0, forcing us to miss other chord note's +c accross-bar-line accidental +c + if (naccbl(icm).gt.0 .and. .not.eximacc) then +c +c Possible carryover accid from prior bar (or prior same-pitch note). +c + do 21 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev) then + jacc = jaccbl(icm,kacc) +c +c Since we are *using* the bar-line accid, must flag it to be saved for next. +c + nusebl = nusebl+1 + jusebl(nusebl) = jacc + lusebl(nusebl) = nolev + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 22 + end if +21 continue +22 continue + end if + ipsav = ipsav+jacc +c +c Midi transpositions +c + ipsav = ipsav+midtc(icm) + end if + if (notmain) then + mcpitch(nmidcrd) = ipsav +c +c Save pitch for tie checks +c + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + imidi(icm) = imidi(icm)+1 + if (ion.eq.0) then + mmidi(icm,imidi(icm)) = ipsav + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ion) + end if + end if + if (ion .eq. 0) then +c +c Only record accids for non-chords, main chord note during chord iteration +c and chordnotes on first call but not during iteration +c + if (iacc.gt.0) then +c +c Set marker for accidental for possible continuations later this bar +c but first check and clear earlier ones on same note. +c + do 23 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + do 24 macc = kacc , naccim(icm)-1 + laccim(icm,macc) = laccim(icm,macc+1) + jaccim(icm,macc) = jaccim(icm,macc+1) +24 continue + go to 25 + end if +23 continue + go to 26 +25 continue + naccim(icm) = naccim(icm)-1 +26 continue +c +c Flag new accidental +c + naccim(icm) = naccim(icm)+1 + laccim(icm,naccim(icm)) = nolev + jaccim(icm,naccim(icm)) = iashft(iacc) + end if +c +c Bail if this is a chord note on the first call (from docrd) +c + if (notmain) then + call chkimidi(icm) + return + end if + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 127 + mmidi(icm,imidi(icm)) = midvelc(icm) + call chkimidi(icm) +7 continue +c +c For tie checks +c + if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm) +c +c Entry point for special rests at section ends (endrest=T) +c +20 continue +c +c Now insert all the ends +c + do 8 ioff = 0 , nmidcrd + if (ioff .eq. 0) then +c +c time to end +c + idur1 = nint(15*time) + if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then + idur = idur1-mgap + else + idur = idur1 + end if +c +c Deal with roundoff problems with 7-tuplets on half or quarters +c + if (idur1 .eq. 69) then + n69(icm) = n69(icm)+1 +c if (mod(n69(icm)+6,7) .gt. 3) idur = 58 + if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1 + else if (idur1 .eq. 34) then + n34(icm) = n34(icm)+1 + if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1 + end if + idurvar = isetvarlen(idur,nby2off) + if (nby2off .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + call chkimidi(icm) + do 1 i = 1 , nby2off + mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256) + if (nby2off .gt. 1) idurvar = idurvar/256 +1 continue + imidi(icm) = imidi(icm)+nby2off-1 + else +c +c Inserting end of chord note, delta time is 0 +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + end if +c +c Note off +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 8*16+icm + mmidi(icm,imidi(icm)) = 8*16+icmm(icm) +c +c Pitch +c + imidi(icm) = imidi(icm)+1 + if (ioff .eq. 0) then + mmidi(icm,imidi(icm)) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ioff) + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + call chkimidi(icm) + if (endrest) then + return + end if +c +c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time +c +8 continue + naccbl(icm) = nusebl + if (nusebl .gt. 0) then +c +c Fix tables of "bar-line" accids that are saved due to consecutive notes. +c + do 30 kacc = 1 , nusebl + laccbl(icm,kacc) = lusebl(kacc) + jaccbl(icm,kacc) = jusebl(kacc) +30 continue + nusebl = 0 + end if +c +c Begin tie checks +c + if (slmon(icm)) then +c +c Prior note had a slur start +c + if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then +c +c We have a tie! (Assumed there would be no accidental on tie-ending note) +c Make a list of times of all events back to the one starting at imidso+1, +c which is at or before where the tie started. Ident tie start and stop by +c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) +c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial +c time. + nsav4tie = 0 + imidt = imidso(icm) +10 nsav4tie = nsav4tie+1 + itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes) + imidt = imidt+nbytes + do 11 j = 1 , 3 + itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j) +11 continue + imidt = imidt+3 + if (nsav4tie .eq. 1) then + itiesav(5,1) = itiesav(1,1) + else + itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+ + * itiesav(5,nsav4tie-1) + end if + if (imidt .ne. imidi(icm)) go to 10 +c +c Find which two pitches agree with saved slur pitch. +c + it1found = .false. + do 12 it2 = 1 , nsav4tie + if (itiesav(3,it2) .eq. ipslon(icm)) then + if (it1found) go to 13 + it1 = it2 + it1found = .true. + end if +12 continue + call printl( + * 'Program error, tied notes, send source to Dr. Don') + it1 = nsav4tie+1 + it2 = nsav4tie+1 +13 continue +c +c List the positions we want to keep +c + jsav = 0 + do 14 isav = 1 , nsav4tie + if (isav.eq.it1 .or. isav.eq.it2) go to 14 + jsav = jsav+1 + itk(jsav) = isav +14 continue + nsav4tie = nsav4tie-2 +c +c Now dump events it1 & it2, recompute times, restack mmidi. +c + imidi(icm) = imidso(icm) + do 15 isav = 1 ,nsav4tie + if (isav .eq. 1) then + idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes) + else + idurvar = isetvarlen(itiesav(5,itk(isav))- + * itiesav(5,itk(isav-1)),nbytes) + end if + imidi(icm) = imidi(icm)+1 + do 16 i = 1 , nbytes + mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256) + if (nbytes .gt. 1) idurvar = idurvar/256 +16 continue + imidi(icm) = imidi(icm)+nbytes-1 + do 17 i = 2 , 4 + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = itiesav(i,itk(isav)) +17 continue +15 continue + end if + slmon(icm) = .false. + levsoff(icm) = 0 + if (.not.dbltie) levson(icm) = 0 + end if + if (levson(icm).gt.0) slmon(icm) = .true. + if (nmidcrd .gt. 0) nmidcrd = 0 + call chkimidi(icm) + return + end + subroutine addstr(notexq,lnote,soutq,lsout) + common /comlast/ islast,usevshrink + logical islast,usevshrink + character*(*) notexq + character*80 soutq + if (lsout+lnote .gt. 72) then + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + end if + if (lsout .gt. 0) then + soutq = soutq(1:lsout)//notexq(1:lnote) + else + soutq = notexq(1:lnote) + end if + lsout = lsout+lnote + return + end + subroutine adjusteskz(ib,squez,istart,istop,poenom) +c +c For block ib, this adds accidental spaces to eskz, for use in getting +c length of xtup bracket and slopes of brackets and beams. +c + parameter (nm=24) + common /comas1/ naskb,task(40),wask(40),elask(40) + real*4 squez(80) + integer*4 istart(80),istop(80) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comeskz2/ eskz2(nm,200) + common /comtol/ tol + common /comntot/ ntot + inmin = istart(ib)+1 + do 10 iaskb = 1 , naskb + if (task(iaskb) .lt. to(istart(ib))-tol) go to 10 + eskadd = wask(iaskb)/poenom-elask(iaskb) + do 11 in = inmin , ntot + if (to(in) .gt. task(iaskb)-tol) then + eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd + if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1 + else + inmin = inmin+1 + end if +11 continue +10 continue + return + end + subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + logical figbass,ispoi,topmods,istype0,done,isbbm + common /comhsp/ hpttot(176) + common /compoi/ ispoi + common /combbm/ isbbm + common /comas3/ ask(2500),iask,topmods + character*40 pathnameq + character*44 basenameq + character*1 sq,chax + character*129 outq + sq = chax(92) + open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex') +c +c Transfer first 5 lines of main internal TeX file +c + do 11 il = 1 , 5 + call moveln(11,12,done) +11 continue + if (istype0) then +c +c Transfer literal TeX stuff from special scratch file +c + rewind(17) +10 call moveln(17,12,done) + if (.not.done) go to 10 + close(17) + end if +c +c Transfer next 2 lines from main scratch file +c + do 3 il = 1 , 2 + call moveln(11,12,done) +3 continue + if (ispoi) write(12,'(a)')sq//'input musixpoi' + if (isbbm) write(12,'(a)')sq//'input musixbbm' + if (figbass) then +c +c Transfer .fig data from scratch (unit 14) into external .tex (unit 12) +c +4 call moveln(14,12,done) + if (.not.done) go to 4 + close(14) + end if + iask = 0 + ihs = 0 +1 read(11,'(a129)',end=999)outq +c +c Hardspaces. +c + if (outq(1:5) .eq. sq//'xard') then + ihs = ihs+1 + outq(2:2) = 'h' + write(outq(12:15),'(f4.1)')hpttot(ihs) + lenout = 19 + go to 9 + end if +c +c This part hard-wires ask's into new .tex file as ast's +c +2 indxask = index(outq,sq//'ask') + if (indxask .ne. 0) then + iask = iask+1 + call putast(ask(iask),indxask,outq) + go to 2 + end if + lenout = llen(outq,129) +9 continue + write(12,'(a)')outq(1:lenout) +c +c If this is the line with "readmod", check for topmods. +c + if (topmods .and. outq(2:8).eq.'readmod') then + topmods = .false. + rewind(16) + do 7 il = 1 , 1000 + read(16,'(a129)',end=8)outq + lenout = llen(outq,129) +c +c We inserted the '%' in subroutine littex, to guarantee including blank. +c + write(12,'(a)')outq(1:lenout) +7 continue +8 continue + close(16) + end if + go to 1 +999 close(11) + close(12) + return + end + subroutine backfill(iunit,oldq,lenold,newq,lennew) +c +c In iunit, looks backward for oldq, overwrites newq +c Safest if both are same length! +c + character*128 lineq(200),nowq + character*(*) oldq,newq + linesback = 0 +1 continue + backspace(iunit) + read(iunit,'(a)')nowq + ndx = index(nowq,oldq(1:lenold)) +c +c Save the line just read +c + linesback = linesback+1 + lineq(linesback) = nowq + if (ndx .eq. 0) then + backspace(iunit) + go to 1 + end if +c +c If here, it's replacement time. +c + lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew) + * //nowq(ndx+lenold:128) + backspace(iunit) + do 2 line = linesback , 1 , -1 + write(iunit,'(a128)')lineq(line) +2 continue + return + end + subroutine beamend(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + character*4 tempq + character*8 noteq + character*79 notexq + ip = ipo(jn) + multip = iand(mult(ivx,ip),15)-8 + if (ixrest(ivx) .eq. 4) then +c +c This is the LAST note in the xtup (i.e., all rests before). Make single. +c + nodur(ivx,ip) = 2**(4-multip) + call notex(notexq,lnote) + ixrest(ivx) = 0 + return + end if + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip-1),27)) + * nodur(ivx,ip)=nodur(ivx,ip)/2 + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = lnoten+3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+1 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+2 + else if (multip .eq. -2) then + notexq = sq//'wh'//noteq + else if (multip .eq. -3) then + notexq = sq//'breve'//noteq + lnote = lnote+3 + else + print* + print*,'(Error in beamend, send source to Dr. Don)' + call stop1() + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + end if + end if + end if + return + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + lnote = 0 +c +c New way, with flipend, which was computed in beamstrt. +c + if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) + * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then +c +c This is not a one-noter from beam-jump. Check if multiplicity has increased +c + if (btest(irest(ivx,ip-1),0)) then +c +c Prior note is a rest, check one before that +c + mp = iand(mult(ivx,ip-2),15)-8 + else + mp = iand(mult(ivx,ip-1),15)-8 + end if + if (multip .gt. mp) then +c +c Assume 1-3, 2-3, or 1-2 +c + do 2 imp = multip , mp+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +2 continue + else if (btest(nacc(ivx,ip-1),27)) then +c +c 2nd member of dotted xtup +c + call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if + end if +c +c Beam termination and direction analysis +c + if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then +c +c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number +c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the +c voice of the 2nd part of jumped beam. (May need special treatment for +c multi-segment jump-beams +c + isbjmp = .true. + ivbj1 = ivx + ivbj2 = 0 + end if + if (.not.btest(irest(ivx,ip),23)) then +c +c This is either a normal beamend or end of a sequence of jump-beam segments, +c so some sort of termination is required +c + ulqq = ulq(ivx,ibmcnt(ivx)) + if (.not.isbjmp .or. ivx.ne.ivbj2) then +c +c Normal termination +c + call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) + else +c +c Terminate a sequence of jump-beam segments. +c + ulqq = chax(225-ichar(ulqq)) + call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote) + end if + end if +c +c And now the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (.not.vxtup(ivx)) then + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (.not.btest(iornq(ivx,ip),13)) then + notexq = notexq(1:lnote)//'p' + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if +c +c 5/25/08 Allow >12 +c 5/9/10 Up to 24; replace 24 with 0 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + if (isbjmp .and. ivx.eq.ivbj2 + * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false. + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamid(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm + character*79 notexq + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + character*8 noteq + character*4 tempq + lnote = 0 + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.btest(irest(ivx,ip),0)) then + multip = iand(mult(ivx,ip),15)-8 +c if (btest(islur(ivx,ip-1),3)) multip = multip+1 +c +c (Above test OK since must have ip>1). Double dotted note preceding +c +c Move the following, because can't ask for note until after checking for +c embedded xtup with number, due to ordering/octave feature. +c +c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) + end if + if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true. + if (vxtup(ivx)) then +c +c In an xtup +c + if (btest(irest(ivx,ip),0)) then +c +c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK +c + nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8)) + call notex(notexq,lnote) +c +c Re-zero so next note does not get confused +c + nodur(ivx,ip) = 0 + return + end if +c if (multip.le.0) then +c if (multip.le.0 .or. +c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip),19) .or. + * btest(nacc(ivx,ip),27)) then + nodur(ivx,ip)=3*nodur(ivx,ip)/2 + else if (btest(nacc(ivx,ip-1),27)) then + nodur(ivx,ip)=nodur(ivx,ip)/2 + end if + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else +c +c Use ulq for stem direction +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + end if + if (btest(nacc(ivx,ip),27)) then +c +c This note is regular dotted non-beamed xtup +c + notexq = notexq(1:3)//'p' + lnote = 4 + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + end if + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + else if (nodur(ivx,ip).eq.0) then +c +c In the beamed xtup but not the last note +c + if (nodur(ivx,ip-1).gt.0) then +c +c Embedded Xtup, mult>0, starts here. Put in number if needed +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + iud = 1 + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1 +c +c Get ip#, notelevel of middle note (or gap) in xtup +c + ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ip),14)) then + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Place number if needed +c + if (.not.btest(islur(ivx,ip),31)) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multip,iud,wheadpt,poenom, + * nolev1(ivx),islope(ivx),slfac, + * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum, + * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.) + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + else +c +c Intermediate note of xtup +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else +c +c Last note of xtup (but not last note of beam!) +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else if (btest(irest(ivx,ip),0)) then + call notex(notexq,lnote) + return + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if +c +c Check if multiplicity changes in a way requiring action +c + ipleft = ip-1 + if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1 + if (.not.btest(islur(ivx,ipleft),20)) then + multl = iand(15,mult(ivx,ipleft))-8 + else + multl = 1 + end if + mub = multip - multl + ipright = ip+1 + if (btest(irest(ivx,ipright),0)) ipright = ipright+1 + if (.not.btest(islur(ivx,ip),20)) then + multr = iand(15,mult(ivx,ipright))-8 + else + multr = 1 + end if + mua = multr-multip + if (mub.gt.0 .or. mua .lt. 0) then +c +c Multiplicity has increased from left or will decrease to right. Need action. +c + if (isbjmp .and. ivx.eq.ivbj2) then + ivb = ivbj1 + ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + else + ivb = ivx + ulqq = ulq(ivx,ibmcnt(ivx)) + end if + if (mua .ge. 0) then + call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote) + else if (multl .ge. multr) then + do 1 im = multip , 1+multr, -1 + call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) +1 continue + else + do 2 im = 1+multr, multip + call ntrbbb(im,'r',ulqq,ivb,notexq,lnote) +2 continue + call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote) + end if + else if (ip .gt. 1) then +c +c Check for 2nd member of dotted xtup +c + if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if +c +c Now put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (isdotted(nodur,ivx,ip)) then +c +c rule out ')' +c + if (.not.btest(iornq(ivx,ip),13)) then + if (.not.btest(islur(ivx,ip),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + else if (btest(nacc(ivx,ip),19) + * .or. btest(nacc(ivx,ip),27)) then +c +c Special dotted notation for 2:1 xtup, or normal dot in xtup +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c 5/25/08 Allow >12 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamn1(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /comoct/ noctup + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*8 noteq + character*79 notexq + ip1 = ipo(jn) + multip = iand(15,mult(ivx,ip1))-8 +c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then + if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then + lnote = 0 +c +c The rest was already written in beamstrt, so just get out of here +c + return + end if + nole = nolev(ivx,ipo(jn)) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ipo(jn)),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ipo(jn)),31)) then + nole = nole + 1 + end if + if (vxtup(ivx) .and. .not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip1),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip1) + nodur(ivx,ip1) = 2**(4-multip) + if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2 + call notex(notexq,lnote) + nodur(ivx,ip1) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + else if (multip .eq. -3) then + notexq = sq//'breve' + lnote = 6 + else + print* + print*,'(Error in beamn1, send source to Dr. Don)' + call stop1() + end if + if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then + notexq = notexq(1:3)//'p' + lnote = 4 + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + end if +c +c Check if mult. decreases from 1st note to 2nd +c + if (ibm2(ivx,ibmcnt(ivx)).gt.ip1 + * .or. btest(islur(ivx,ip1),20)) then +c +c More than one note or single-note before a multiplicity-down-up "][" +c + if (btest(islur(ivx,ip1),20)) then + multr = 1 + else if (.not.btest(irest(ivx,ip1+1),0)) then + multr = iand(15,mult(ivx,ip1+1))-8 + else + multr = iand(15,mult(ivx,ip1+2))-8 + end if + lnote = 0 + if (multr .lt. multip) then + do 1 im = multip , multr+1 , -1 + call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +1 continue + end if + end if +c +c Put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 +c +c Check for dot +c + isdotm = .false. + if (.not.vxtup(ivx)) then + nd = nodur(ivx,ipo(jn)) + if (nd.ne.0) then + if (2**log2(nd).ne.nd) then + if (.not.btest(iornq(ivx,ip1),13)) then + if (.not.btest(islur(ivx,ip1),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if + else if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) then +c +c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c Do the number; 0 if 12 +c +c 5/25/08 allow >12 +c + if (.not.btest(irest(ivx,ip1),24)) then +c call istring(mod(ivx,12),noteq,len) + call istring(mod(ivx,24),noteq,len) + else +c call istring(mod(ivbj1,12),noteq,len) + call istring(mod(ivbj1,24),noteq,len) + end if + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + character*79 inameq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm + common /comeskz2/ eskz2(nm,200) + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c The following is just to save the outputs from SetupB for the case of +c xtups starting with a rest, where beamstrt is called twice. +c + common /comipb/ nnb,sumx,sumy,ipb(24),smed + character*8 noteq + character*79 notexq,tempq + integer nornb(nm),ihornb(nm,24) + real*4 space(80),squez(80) + logical novshrinktop,cstuplet,usexnumt + common /comnvst/ novshrinktop,cstuplet + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ibc = ibmcnt(ivx) + ipb1 = ibm1(ivx,ibc) + multb = iand(15,mult(ivx,ipb1))-8 + ip = ipo(jn) +c +c Compute slopes and note offsets from start of beam. Inside SetupB, for each +c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. +c + if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) + * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) + if (btest(nacc(ivx,ip),21)) then +c +c This is start of later segment of single-slope beam group so use slope and +c height from prior beam. Slope is already OK. +c + issb(ivx) = issb(ivx)+1 + nolev1(ivx) = lev1ssb(ivx,issb(ivx)) + end if + lnote = 0 + drawbm(ivx) = .true. + if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then + vxtup(ivx) = .true. + nxtinbm(ivx) = nxtinbm(ivx)+1 +c +c irest(28)=>Xtup starts on this note. Set up for xtuplet. +c Number goes on notehead side at middle note (or gap) of xtup, unless that +c puts it in staff, then it flops to stem (or beam) side. +c __ __ +c | | | O | | +c O | | O +c |___| O |__| | +c +c iud -1 -1 1 1 ...stem direction +c iflop 0 1 -1 0 ...direction of flop +c iup -1 1 -1 1 ...direction of number and bracket +c + iud = 1 + if (ulq(ivx,ibc) .eq. 'u') iud = -1 +c +c Get ip#, note level of middle note (or gap) in xtup +c + ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ipb1),14)) then +c +c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) +c + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Determine if a beam is to be drawn +c + do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc) + if (iand(15,mult(ivx,ipp))-8 .le. 0) then + drawbm(ivx) = .false. + go to 6 + end if +5 continue + drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18) +6 continue +c +c Are we using tuplet.tex? +c + usexnumt = cstuplet .and. .not.drawbm(ivx) +c +c Place xtup number if needed +c + if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multb,iud,wheadpt, + * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1), + * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)), + * iup,irest(ivx,ipb1),usexnumt) + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam +c + if (.not.btest(islur(ivx,ipb1),31)) then +c +c Number printing has not been suppressed, so put in the bracket. +c scale = stretch factor for bracket if there are asx's +c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) +c + xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1) + * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib)) + if (iup .eq. 1) then + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'ovbkt' + else + notexq = sq//'ovbkt' + end if + else + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'unbkt' + else +c +c Introduced 12/5/98, req'd due to possible presence of in-line TeX +c + notexq = sq//'unbkt' + end if + end if + lnote = lnote+6 + if (iline.eq.1) then + smed = smed/(1.-fracindent) + end if + xslope = 1.8*smed*slfac + islope(ivx) = nint(xslope) + nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1)) + if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1 + if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4 + levbracket = nolev1(ivx) + if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1 + call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+lnoten+1 + if (xnsk .lt. 0.995) then + write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk + lnote = lnote+4 + else if (xnsk .lt. 9.995) then + write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk + lnote = lnote+5 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + if (btest(mult(ivx,ipb1),4)) then +c +c Tweak slope of bracket +c + islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16 + end if + if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (islope(ivx) .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx) + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx) + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx) + lnote = lnote+1 + end if +c +c Done with bracket +c + end if + if (ixrest(ivx) .eq. 1) then +c +c Put in the rest. Possible problem: Rest is a spacing char, but between +c beamstrt and beamn1 some non-spacing chars. are inserted. +c + 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 +c +c No need to come back through this subroutine (as would if rest starts bar +c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. +c + ixrest(ivx) = 0 + end if + return + end if +c +c End if block for non-beamed xtup start...note we returned +c + if (ixrest(ivx) .eq. 1) then +c +c Insert rest at start of beamed xtup. See above note for possible problem. +c + nodur(ivx,ipb1) = 2**(4-multb) + call notex(tempq,ltemp) + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//tempq(1:ltemp) + else + notexq = tempq(1:ltemp) + end if + lnote = lnote+ltemp +c +c Re-zero just in case! +c + nodur(ivx,ipb1) = 0 + ibm1(ivx,ibc) = ibm1(ivx,ibc)+1 +c +c See if next note is a non-rest +c + if (.not.btest(irest(ivx,ipb1+1),0)) then + ixrest(ivx) = 2 + else +c +c Suppress reprinting xtup number next time through beamstrt +c + islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31) +c +c Set new xtup start flag +c + irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28) + end if + return + end if + end if +c +c Just ended if block for xtups +c + if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then +c +c Move actual note writing to beamend +c + ixrest(ivx) = 4 + return + end if + if (issb(ivx) .eq. 0) then +c +c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed +c + iadj = igetbits(ipl(ivx,ipb1),6,11)-30 + if (iadj .ne. -30) then + nolev1(ivx) = nolev1(ivx)+iadj + do 2 isssb = 1 , nssb(ivx) + lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj +2 continue + end if + iadj = igetbits(ipl(ivx,ipb1),6,17)-30 + if (iadj .ne. -30) then + islope(ivx) = islope(ivx)+iadj + if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx)) + if (nssb(ivx) .gt. 0) then +c +c Cycle thru non-rest notes in SSBG, looking for bmstrts. +c + isssb = 0 + do 4 inb = 2, nnb + if (btest(nacc(ivx,ipb(inb)),21)) then +c +c Beam segment start. New start level + isssb = isssb+1 + lev1ssb(ivx,isssb) = + * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac + end if +4 continue + end if + end if + end if + iadj = igetbits(islur(ivx,ipb1),2,27) + addbrack = .false. + if (btest(ipl(ivx,ipb1),30)) then +c +c Check for altered starting polarity. Only in forced beams. Nominal start +c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). +c + if (ulq(ivx,ibc).eq.'u' .and. + * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'loff{' + else + notexq = notexq(1:lnote)//sq//'loff{' + end if + lnote = lnote+6 + addbrack = .true. + else if (ulq(ivx,ibc).eq.'l' .and. + * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'roff{' + else + notexq = notexq(1:lnote)//sq//'roff{' + end if + lnote = lnote+6 + addbrack = .true. + end if +c +c Check end level for possible flipping in forced beam. Have to do it +c here since with multiple voices, xelsk will not be preserved. +c + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then + bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc)) + else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then + bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc)) + end if + end if + call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote) +c +c Put in name of start level and slope, after correcting nolev1 if xtup +c started with a rest. +c + if (ixrest(ivx).eq.2) nolev1(ivx) = + * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac) + call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1)) + if (islope(ivx) .lt. 0) then + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+4+lnoten + write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}' + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+1+lnoten + write(notexq(lnote:lnote),'(i1)')islope(ivx) + end if +c +c Check for beam-thk fine-tuning +c + if (iadj .gt. 0) then + do 1 imp = multb+iadj , multb+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote) +1 continue + end if +c +c If we shifted, must close with right bracket +c + if (addbrack) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Get 'floor' zmin for figures +c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height +c won't be adjusted. If anyone ever needs that, need to duplicate this +c functionality up above, before exiting. +c + if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then + if (ivx .eq. 1) then + ivf = 1 + else + ivf = ivxfig2 + end if + zmult = 1.2*(multb-1) + ymin = 100. + do 3 inb = 1, nnb + if (isfig(ivf,ipb(inb))) then + if (ulq(iv,ibc) .eq. 'u') then + ybot = nolev(iv,ipb(inb)) + else + ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx) + * -stemlen-zmult + end if + ymin = min(ymin,ybot) + end if +3 continue + maxdrop = ncmid(iv,ipb1)-4-ymin+5.01 + ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop) + end if +c +c Compute ornament levels if needed +c + NomOrnLev = ncmid(iv,ipb1)+5 + iorn = 0 + do 8 inb = 1 , nnb + ip = ipb(inb) + if (.not.btest(iornq(ivx,ip),23)) go to 8 + if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then +c +c letter-dynamic or hairpin ending under down-beamed +c + iorn = iorn+1 + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + else if (.not.btest(ipl(ivx,ip),10)) then +c +c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD +c +c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if +c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) +c + if (ulq(ivx,ibc).eq.'u' .and. + * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then + iorn = iorn+1 + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + end if + else +c +c In a chord. Orn may be on main note or non-main or both. Set ihornb if +c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note +c + do 10 icrd1 = 1 , ncrd + if (iand(255,icrdat(icrd1)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11 +10 continue +11 continue +c +c Find outermost note, min or max depending on beam direction ulq. xto is true +c if there's an ornament on that note. Expand orn list to include ._, since if +c on extreme chord note in beam, will move. +c So ornaments are all except 0,4,13 (,g,) +c + levx = nolev(ivx,ip) + xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0 + icrdx = 0 + do 12 icrd = icrd1 , ncrd + if (iand(255,icrdat(icrd)) .ne. ip .or. + * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13 + levc = iand(127,ishft(icrdat(icrd),-12)) + if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or. + * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then + levx = levc + icrdx = icrd + xto = iand(icrdorn(icrd),4186094).gt.0 + end if +12 continue +13 continue +c +c If there's orn on extreme note, do stuff +c + if (xto) then + iorn = iorn+1 + if (ulq(ivx,ibc) .eq. 'u') then + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + else + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + end if + if (icrdx .eq. 0) then +c +c Affected ornament is on main note +c + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + else + icrdorn(icrdx) = ibset(icrdorn(icrdx),22) + end if + end if + end if +8 continue +c +c Henceforth nornb will be a counter. +c + if (iorn .gt. 0) nornb(ivx)=1 + if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0 + return + end + block data + parameter (nm=24) + common /comtol/ tol + common /comtrans/ cheadq + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + logical usefig + common /comstart/ facmtr + character*60 cheadq + character*120 instrq,titleq,compoq + logical headlog + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /combmh/ bmhgt,clefend + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) +c + data tol /.001/ + data cheadq + * /' '/ + data gslfac /9./ + data instrq,titleq,compoq,headlog /3*' ',.false./ +c +c meter space (pts) = xb4mbr = musicsize*facmtr +c + data facmtr /0.55/ + data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt + * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 , + * .7,.7 ,.9 ,.5 ,2.3 ,1.1 / + data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac + * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 / + data rtshfac / 1.0 / + data isize /nm*0/ +c +c From other +c + data ptheight,widthpt,hoffpt,voffpt, + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh + * / 740. , 524. , 0., 0., + * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12., + * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 / + data fracsys /30*0./ + data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1, +c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3, + * -0.3,0.3 / + data kbdrests /.false./, + * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/ + data EarlyTransOn, LaterInstTrans /2*.false./ + data iInstTrans /nm*0/ + end + subroutine catspace(space,squez,nnsk) + parameter (nkb=3999,maxblks=4000) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + logical gotclef + do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1 + if (abs(space-durb(iptr)) .lt. tol) then + if (abs(squez-sqzb(iptr)) .lt. tol) then +c +c Increment pre-existing entry +c + nnpd(iptr) = nnpd(iptr)+nnsk + return + end if + end if +16 continue +c +c Didn't find current duration & squez, so add a new entry. +c No particular reason to keep in order, so add at the end. +c + nnpd(nptr(ibarcnt+1)) = nnsk + durb(nptr(ibarcnt+1)) = space + sqzb(nptr(ibarcnt+1)) = squez + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + return + end + character*1 function chax(n) +c +c The only reason for this seemingly do-nothing function is to get around an +c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! +c + chax = char(n) + return + end + subroutine checkdyn(lineq,iccount,ibar) + character*128 lineq + character*1 durq,chax + character*4 dynsymq + logical txtdyn + txtdyn = .false. +c +c On entry, iccount is on "D" +c + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c Dynamic text +c + iend = index(lineq(iccount+2:128),'"') + if (iend .eq. 0) then + call errmsg(lineq,iccount+1,ibar, + * 'Dynamic text must be terminated with double quote!') + call stop1() + end if +c +c Set iccount to character after 2nd ", and set ipm +c + iccount = iccount+iend+2 + ipm = index('- +',lineq(iccount:iccount)) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "-", "+", or blank here!') + call stop1() + end if + else +c +c Expect ordinary dynamic +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) + if (ipm .gt. 0) go to 2 +1 continue +2 continue + if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then + call errmsg(lineq,iend-1,ibar, + * 'Wrong length for dynamic mark!') + call stop1() + end if + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ', + * dynsymq)+3)/4 + if (idno .eq. 0) then + call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!') + call stop1() + end if + iccount = iend + end if + if (ipm .ne. 2) then +c +c There is a vertical shift, have "+" or "-" +c + iccount = iccount+1 + if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected integer here for vertical offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + if (idno .gt. 63) then + call errmsg(lineq,iccount-1,ibar, + * 'Vertical offset for dynamic mark must be (-63,63)!') + call stop1() + end if + ipm = index('- +',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "+", "-", or blank here!') + call stop1() + end if + if (ipm .ne. 2) then +c +c There is a horizontal shift +c + iccount = iccount+1 + if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected number here for horizontal offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + if (idno .gt. 255) then + call errmsg(lineq,iccount-1,ibar, + * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!') + call stop1() + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibar, + * 'There should be a blank here!') + call stop1() + end if + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + return + end + subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) +c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, +c * icashft) + logical found1,iscacc,isarp,btest + integer icrdat(193) + found1 = .false. +c +c icashft will be max left shift of accid's in chord notes. +c Used only for spacing checks. +c Will include left shift of chord note itself. +c Rezero after use. +c + do 18 icrd = 1 , ncrd +c +c This if block cycles thru all chord notes on ivx,ip; then returns. +c + if (iand(255,icrdat(icrd)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then + found1 = .true. + iscacc = iscacc .or. + * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) +c +c Accid on this chord note, and it's not midi-only. +c +c irshft = igetbits(icrdot(icrd),7,20) +cc +cc Include increment for notehead shift +cc +c if (btest(icrdat(icrd),23)) then +c if (irshft .eq. 0) then +c irshft = 44 +c else +c irshft=irshft-20 +c end if +c end if +c if (irshft .ne. 0) then +cc +cc Accid on chord note is shifted. Include only left shift, in 20ths. +cc +c if (irshft .lt. 64) icashft = max(icashft,64-irshft) +c end if +c end if + isarp = isarp .or. btest(icrdat(icrd),25) + else if (found1) then + return + end if +18 continue + return + end + subroutine chkimidi(icm) + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + if (imidi(icm) .ge. mv) then + print* + print*,'Midi file is too long! It will be corrupted or worse' + write(*,'(a6,2x,4i8)') + * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3) + end if + return + end + subroutine chklit(lineq,iccount,literr) + character*128 lineq + character*1 charq,chax + literr = 0 + itype = 1 +17 call g1etchar(lineq,iccount,charq) + if (charq .eq. chax(92)) then + itype = itype+1 +c if (itype .eq. 2) then +c if (iccount .ne. 2 ) then +cc +cc type 2 or 3 tex string not starting in column 1 +cc +c literr = 3 +c return +c end if +c else if (itype .gt. 3) then + if (itype .gt. 3) then + literr = 1 + return + end if + go to 17 + end if + lenlit = itype +18 call g1etchar(lineq,iccount,charq) + if (charq.eq.chax(92)) then + call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then +c +c Starting a new tex command withing the string +c + lenlit = lenlit+2 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + else + lenlit = lenlit+1 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + return + end + subroutine chkpm4ac(lineq,iccount,nacc,moved) +c +c Called after getting +/-/ in a note (not rest). iccount is on the +-<>. +c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits +c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed +c numbers. If moved=.true., iccount on exit is on end of last number. +c If moved=.false., iccount still on +/- +c + logical moved,ishorz + character*128 lineq + character*1 durq + if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and. + * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then +c +c Prior char was accid & next is #; this may be start of accidental shift. +c Must test for "." above in case we get "<" or ">" +c + ipm = index('- +< >',lineq(iccount:iccount))-2 + if (lineq(iccount+1:iccount+1).eq.'.' .and. + * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then +c +c Rare case of [accid][+/-].[letter]. Bail out +c + moved = .false. + return + end if + ishorz = ipm .gt. 1 +c +c Save iccount in case it's not accid shift and we have to reset. +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (ishorz .or. index('+-',durq).gt.0) then +c +c This has to be accidental shift. Set vert. shift. +c + if (.not.ishorz) then +c +c +/- syntax, both shifts set, vertical first +c + call setbits(nacc,6,4,int(ipm*fnum+32.5)) + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else +c +c syntax, only horiz set +c + ipm = ipm-3 + end if +c +c Set horiz. shift +c + call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35))) + iccount = iccount-1 + moved = .true. + else +c +c False alarm. Reset everything and flow onward +c + moved = .false. + iccount = icsav + end if + else +c +c Either prior char was not 'sfn' or next was not digit, so take no action +c + moved = .false. + end if + return + end + subroutine clefsym(isl,notexq,lnote,nclef) +c +c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. +c + character*(*) notexq + character*1 chax + nclef = iand(ishft(isl,-12),7) + if (nclef .eq. 0) then +c +c treble +c + nlev = 2 + else if (nclef .gt. 6) then +c +c French violin +c + nlev = 0 + else if (nclef .lt. 5) then +c +c C-clef +c + nlev = 2*nclef-2 + else +c +c F-clef +c + nlev = 2*nclef-6 + end if + notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7)) + * //chax(48+nlev) + lnote = 10 + return + end + subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime, + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c micrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c segrb(1|2,.) x|y-coord of right-bdry segment +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c icrdot0 = top-down level-rank of main note among accid-notes +c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes +c twooftwo will be true 2nd time thru; signal to store shifts w/ notes +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50) + integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50), + * isetshft(10),ksegrb0(50) + logical lasttime,mainnote,twooftwo + data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 / + data segar / +c +c Fancy sharp boundary. fl,sh,na,dfl,dsh +c + * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2, +c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , +c meas value for y, natural is 1.6 + * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2, + * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / + data segal / +c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , +cc (meas. value is 3.08) ^^^^ +cc Raise top of flat so it interferes with bottom of sharp + * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2, + * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2, + * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / +c +c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) +c + data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 / +c +c Set up barrier segrb(iseg,ipoint) to define coords of corner points +c on stem+notes +c + do 11 iseg = 1 , nsegrb0 + segrb(1,iseg) = segrb0(1,iseg) + segrb(2,iseg) = segrb0(2,iseg) + ksegrb(iseg) = ksegrb0(iseg) +11 continue + nsegrb = nsegrb0 + rmsshift = 0. + shiftmin = 1000. + do 1 iwa = 1 , naccid +c +c Initialize shift for this note +c + shift = 0. + mainnote = micrd(iwa).eq.0 + isetshft(iwa) = -1 +c +c Get note level and accidental type +c + if (mainnote) then + nolev = nolevm + iacctype = iacctbl(igetbits(nacc,3,0)) + else + nolev = igetbits(icrdat(micrd(iwa)),7,12) + iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20)) + end if +c +c Cycle thru segments on right edge of this accidental +c + do 2 isega = 1 , nsegar(iacctype)-1 + ybotaseg = nolev+segar(iacctype,2,isega) + ytopaseg = nolev+segar(iacctype,2,isega+1) +c +c Cycle thru segments of right-hand barrier +c + do 3 isegrb = 1 , nsegrb-1 +c +c Must find all barrier segments that start below ytopseg & end above ybotseg +c + if (segrb(2,isegrb) .lt. ytopaseg) then +c +c Barrier seg starts below top of accid +c Check if barrier seg ends above bottom of accid +c + if (segrb(2,isegrb+1) .gt. ybotaseg) then + if (shift .gt. + * segrb(1,isegrb)-segar(iacctype,1,isega)) then + shift = segrb(1,isegrb)-segar(iacctype,1,isega) +c +c Record the cause of the shift +c + isetshft(iwa) = ksegrb(isegrb) + end if + end if +c +c Does barrier segment end above top of accid seg? +c + if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4 + end if +3 continue +4 continue +2 continue + if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001 + * .and. .not.lasttime) then +c if (nolev .eq. levmaxacc) then + if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then + rmsshift = 1000. + return + end if +c +c Does the following properly account for left-shifted noteheads? +c +c Top-down rank of this note we just shifted +c + if (mainnote) then + irank = icrdot0 + else + irank = igetbits(icrdot(micrd(iwa)),3,27) + end if +c +c Compare level-rank of this note vs. that of note that caused the shift. +c This has effect of checking for basic interferences from top down. +c +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c + if (isetshft(iwa) .lt. 0) then + iranksetter = 0 + else if (isetshft(iwa) .eq. 0) then + iranksetter = icrdot0 + else + iranksetter = igetbits(icrdot(isetshft(iwa)),3,27) + end if + if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then + rmsshift = 1000. + return + end if + end if + rmsshift = rmsshift+shift**2 + if (lasttime .and. abs(shift).gt..0001) then + if (mainnote) then + if (.not.btest(nacc,29)) go to 10 + else + if (.not.btest(icrdat(micrd(iwa)),29)) go to 10 + end if +c +c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there +c was a manual shift but auto-shift was zero, will not come thru here, but shift value +c will be left intact. +c + if (mainnote) then + shift = shift+.05*(igetbits(nacc,7,10)-107) + else + shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107) + end if +10 continue + if (twooftwo) then +c +c Record the shift for this accidental +c + if (shift .lt. -5.35) then + call printl(' ') + call printl('WARNING: auto-generated accidental '// + * 'shift too big for PMX, ignoring') + else + ishift = nint(20*(shift+5.35)) + if (mainnote) then + call setbits(nacc,7,10,ishift) + else + call setbits(icrdot(micrd(iwa)),7,20,ishift) + end if + end if + else +c +c This is the earlier call to precrd, so need minimum shift +c + shiftmin = min(shiftmin,shift) + end if + end if +c +c Bail out if this is the last accidental to check +c + if (iwa .eq. naccid) go to 1 +c +c Add this accidental to the right barrier! Count down from highest barrier segment, +c find 1st one starting below top of accid, and first one starting below bot. +c + do 5 ibelowtop = nsegrb , 1 , -1 + if (segrb(2,ibelowtop) .lt. + * nolev+segal(iacctype,2,nsegal(iacctype))) then + do 9 ibelowbot = ibelowtop , 1 , -1 + if (segrb(2,ibelowbot) .lt. + * nolev+segal(iacctype,2,1)) go to 6 +9 continue + print*,'Oops2!' + call stop1() + end if +5 continue + print*,'Ugh0! in crdaccs' + call stop1() +6 continue + netgain = nsegal(iacctype)-ibelowtop+ibelowbot +c +c Shift high segments up +c + if (netgain .ge. 0) then + do 7 isegrb = nsegrb , ibelowtop+1 , -1 + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +7 continue +c +c Set up 1st segment above accid +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + else +c +c netgain<0, must remove segments. Use same coding but reverse order, +c work from bottom up +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + do 12 isegrb = ibelowtop+1 , nsegrb + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +12 continue + end if +c +c Insert new segments +c + do 8 isega = 1 , nsegal(iacctype)-1 + segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega) + segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega) + if (mainnote) then + ksegrb(ibelowbot+isega) = 0 + else + ksegrb(ibelowbot+isega) = micrd(iwa) + end if +8 continue +c +c Update number of barrier segments +c + nsegrb = nsegrb+netgain +cc +cc Temporary printout for boundary segments as built up +cc +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) +cc +1 continue ! next accidental + if (lasttime .and. .not.twooftwo) then +c +c This is the final call on the pre-ask pass, so compute left-shift rqmt. +c + icashft = nint(-20*shiftmin) + end if +cc +cc Temporary printout for boundary segments +cc +c if (twooftwo) then +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa),isetshft(iwa),iwa=1,naccid) +c end if +cc + return + end + subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm, + * levmaxacc,levminacc,icrdot0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c +c This is called once per multi-accidental chord. In here, loop over all +c permutations of the order of accidental as stored in kicrd. Each time thru +c loop, call crdacc once, get rms shift. Only save permutation and rms value +c if it is less than old value. +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c Make consistent? 120106 +c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + real*4 segrb0(2,50) + logical btest,tagged,manual,lshift,twooftwo +cc +cc Temporary printout of level-rankings +cc +c write(15,'()') +c do 98 iacc = 1 , naccid +c if (kicrd(iacc) .eq. 0) then +c write(15,'(3i5)')nolevm,icrdot0 +c else +c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), +c * igetbits(icrdot(kicrd(iacc)),3,27) +c end if +c98 continue +cc +c +c Initialize right-barrier +c + segrb0(1,1) = 0. + segrb0(2,1) = -1000. + segrb0(1,2) = 0. + segrb0(2,2) = 1000. + nsegrb0 = 2 + ksegrb0(1) = -1 + ksegrb0(2) = -1 +c +c Search for left-shifted notes, Make up the initial right-barrier, which +c will be good for all permutations. +c irest()(27) is set if any notes are left-shifted +c Must use ALL chord notes, not just ones w/ accid's. +c + if (btest(irest,27)) then + do 15 icrd = icrd1-1, icrd2 + if (icrd .eq. icrd1-1) then +c +c Main note +c +c lshift = btest(ipl,8) + lshift = btest(ipl,8) .or. btest(nacc,31) + if (lshift) nolev = nolevm + else +c +c Chord note +c + lshift = btest(icrdat(icrd),23) +c if (lshift) nolev = igetbits(icrdat(icrd),7,12) + if (lshift) then + nolev = igetbits(icrdat(icrd),7,12) + if (btest(nacc,31) .and. nolev.eq.nolevm+1) then +c +c This note is not really shifted, It is the upper of a 2nd with the main +c note on an upstem, and Main note must be shifted. +c nacc(31) signals the real truth. +c + lshift = .false. + end if + end if + end if + if (lshift) then + do 16 isegrb = 1 , nsegrb0-1 + if (segrb0(2,isegrb+1) .gt. nolev-1) then +c +c Add this notehead to the right boundary here. Move all higher segs up 2. +c + do 17 iiseg = nsegrb0 , isegrb+1 , -1 + segrb0(1,iiseg+2) = segrb0(1,iiseg) + segrb0(2,iiseg+2) = segrb0(2,iiseg) + ksegrb0(iiseg+2) = ksegrb0(iiseg) +17 continue + go to 18 + end if +16 continue +18 continue +c +c Insert notehead into list. Set kseg=-2 to signal notehead shift. +c + iiseg = isegrb+1 + segrb0(1,iiseg) = -1.2 + segrb0(2,iiseg) = nolev-1. + ksegrb0(iiseg) = -2 + segrb0(1,iiseg+1) = 0. + segrb0(2,iiseg+1) = nolev+1. + ksegrb0(iiseg+1) = -1 + nsegrb0 = nsegrb0+2 + end if +15 continue + end if +c +c Done setting right barrier for left-shifted noteheads +c + tagged = .false. + manual = .false. +c +c Preprocess to check for manual shifts. +c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then +c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, Observe all manual shifts. +c End if +c End if +c + maxmanshft = 0 + do 13 i = 1 , naccid + if (kicrd(i) .eq. 0) then +c +c Main note +c + manshft = igetbits(nacc,7,10) + if (manshft .ne. 0) then + manual = .true. + if (btest(nacc,29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + else +c +c Chord note +c + manshft = igetbits(icrdot(kicrd(i)),7,20) + if (manshft .ne. 0) then + manual = .true. + if (btest(icrdat(kicrd(i)),29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + end if +13 continue + if (manual) then + if (tagged) then +c +c zero out all untagged shifts +c + do 14 i = 1 , naccid + if (kicrd(i) .eq. 0) then + if (.not.btest(nacc,29)) call setbits (nacc,7,10,0) + else + if (.not.btest(icrdat(kicrd(i)),29)) + * call setbits (icrdot(kicrd(i)),7,20,0) + end if +14 continue + else +c +c There are manual shifts but none tagged. Only proceed if "Ao" was entered +c + if (.not.btest(nacc,28)) then + icashft = maxmanshft + return + end if + end if + end if + if (btest(nacc,28)) then +c +c Take the accidentals in order as originally input, then exit. +c + call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return +c end if + else if (naccid .eq. 3) then +c +c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd +c then place in order top, bottom, middle. +c + do 20 i = 1 , 3 + if (kicrd(i) .eq. 0) then + irank = icrdot0 + nolev = nolevm + else + irank = igetbits(icrdot(kicrd(i)),3,27) + nolev = igetbits(icrdat(kicrd(i)),7,12) + end if + if (irank .eq. 1 ) then + micrd(1) = kicrd(i) + else + micrd(5-irank) = kicrd(i) + end if + if (irank .eq. 2) then + levmidacc = nolev + end if +20 continue + if (levmaxacc.ne.levmidacc+1 .and. + * levmidacc.ne.levminacc+1) then + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end if + end if + rmsmin = 100000. +c +c Initialize permutation array +c + do 7 i = 1 , naccid + iperm(i) = i +7 continue +c +c Start looping over permutations +c + do 8 ip = 1 , 5041 + if (ip .ne. 1) then +c +c Work the magic algorithm to get the next permutation +c + do 1 k = naccid-1 , 1 , -1 + if (iperm(k) .le. iperm(k+1)) go to 2 +1 continue +c +c If here, we just got the last permutation, so exit the loop over permutations +c + go to 10 +2 continue + do 3 j = naccid , 1 , -1 + if (iperm(k) .le. iperm(j)) go to 4 +3 continue +4 continue + it = iperm(j) + iperm(j) = iperm(k) + iperm(k) = it + is = k+1 + do 5 ir = naccid , 1 , -1 + if (ir .le. is) go to 6 + it = iperm(ir) + iperm(ir) = iperm(is) + iperm(is) = it + is = is+1 +5 continue +6 continue + end if +c +c New we have a permutation. Take icrd values out of kicrd and put them into +c micrd in the order of the permutation +c + do 9 i = 1 , naccid + micrd(i) = kicrd(iperm(i)) +9 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false., + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +cc +cc Temporary printout +cc +c write(15,*)'perm done, rmsshift:',rmsshift +cc + if (rmsshift .lt. rmsmin) then +c +c Save this permutation, reset minrms +c + do 11 i = 1 , naccid + ipermsav(i) = iperm(i) + rmsmin = rmsshift +11 continue + end if +8 continue + print*,'Should not BEEEEEE here!' + call stop1() +10 continue +c +c Done looping, get info for the final choice +c + do 12 i = 1 , naccid + micrd(i) = kicrd(ipermsav(i)) +12 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end + subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut) + character*1 sq,chax + character*3 acsymq + character*8 noteq + character*79 notexq + logical btest,caut + sq = chax(92) + if (ihshft .eq. -107) ihshft=0 +cc +cc If main note shifted left, so shift accid. Terminate below, when acc. is done. +cc + if (ihshft .ne. 0) then +c +c Accid must be shifted horizontally +c + if (ihshft .lt. 0) then + notexq = sq//'loffset{' + ihshft = -ihshft + else + notexq = sq//'roffset{' + end if + hshft = .05*ihshft + if (hshft .lt. 1.) then + write(notexq(10:12),'(f3.2)')hshft + lnote = 12 + else + write(notexq(10:13),'(f4.2)')hshft + lnote = 13 + end if + notexq = notexq(1:lnote)//'}{'//sq + lnote = lnote+3 + else + notexq = sq + lnote = 1 + end if + if (btest(nacc,3)) then + notexq = notexq(1:lnote)//'big' + lnote = lnote+3 + end if + if (caut) then +c +c Cautionary accidental. Need to define bigcna,... in pmx.tex +c + notexq = notexq(1:lnote)//'c' + lnote = lnote+1 + end if + call accsym(nacc,acsymq,lacc) + notexq = notexq(1:lnote)//acsymq(1:lacc) + lnote = lnote+lacc + noleva = nolev + if (ivshft .ne. 0) noleva = noleva+ivshft-32 + call notefq(noteq,lnoten,noleva,ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihshft .ne. 0) then +c +c Terminate horizontal shift +c + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + return + end + subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt, + * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen, + * dotxtup,nacc) + parameter (nm=24,mv=24576) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical lowdot,dotxtup + integer*4 ihornb(nm,24),nornb(nm) + character*1 ulq(nm,9),chax + character*7 nosymq + character*8 noteq + character*79 notexq,outq + character*80 soutq + logical btest,isleft,isright,beamon + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c This subr. once produced notexq for entire chord. 10/18/97 altered to write +c chord notes as we go. 10/22/97 find range of icrd first. +c 2/25/98 moved rangefinding to precrd so done before slurs, so now +c on entry, icrd1, icrd2 define range of icrd for this chord. +c +c Set counter (for this note) for chord notes present. Set notmain=T. +c Will test for notmain=.true. in addmidi to tell whether to save pitch. +c + nmidcrd = 0 + notmain = .true. + crdacc = .false. + do 5 icrd = icrd1 , icrd2 + lnote = 0 + nolev = igetbits(icrdat(icrd),7,12) +c +c 3/8/03 save original pitch to use in midi, in case 2nds alter things. +c + nolevo = nolev +c +c Check for special situations with 2nds (see precrd). +c + if (btest(nacc,30)) then + if (nolev .eq. nolevm-1) nolev = nolevm + else if (btest(nacc,31)) then + if (nolev .eq. nolevm+1) nolev = nolevm + end if +c +c Lower dot for lower-voice notes?. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest (cannot be a rest in a chord!) +c. 5. Flag (lowdot) is set to true +c + if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then + if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then + if (btest(icrdat(icrd),26)) then +c +c Note already in movdot list. Drop by 2. +c + call setbits(icrdot(icrd),7,0, + * igetbits(icrdot(icrd),7,0)-20) + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3)) + end if + end if + end if + if (btest(icrdat(icrd),26)) then +c +c Move the dot. +c + updotc = 0.1*(iand(127,icrdot(icrd))-64) + rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64) + call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3)) + end if + isleft = btest(icrdat(icrd),23) + isright = btest(icrdat(icrd),24) +c +c Check for ornament in chord. +c + if (icrdorn(icrd) .gt. 0) then + call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq, + * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout, + * ip,0,beamon,.true.) +c +c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, +c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, +c * notcrd,beamon,iscrd) +c + call addstr(outq,lout,soutq,lsout) + end if +c +c Chord-note symbol. First check for breve +c + if (nodu .eq. 128) then + nosymq = chax(92)//'zbreve' + lsym = 7 + else +c +c Not a breve chord. Get first letters in chord-note symbol +c + if (isleft) then + nosymq = chax(92)//'l' + else if (isright) then + nosymq = chax(92)//'r' + else + nosymq = chax(92)//'z' + end if + if (nodu .ge. 64) then + nosymq = nosymq(1:2)//'w' + else if (nodu .ge. 32) then + nosymq = nosymq(1:2)//'h' + else + nosymq = nosymq(1:2)//'q' + end if + if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then + lsym = 3 + else if (.not.btest(islur,3) .or. dotxtup) then +c +c Single dot +c + nosymq = nosymq(1:3)//'p' + lsym = 4 + else +c +c Double dot +c + nosymq = nosymq(1:3)//'pp' + lsym = 5 + end if + end if + if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then +c +c Accidental and not MIDI-only. Build up bits 0-3 of nacc +c + nactmp = igetbits(icrdat(icrd),3,20) +c +c Kluge for bigness. Only means 'As' has not been issued +c + if (bacfac .ne. 1.e6) nactmp = nactmp+8 + call doacc(igetbits(icrdot(icrd),7,20)-107, + * igetbits(icrdot(icrd),6,14), +c * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) +c Get original nolev, not altered to deal with 2nds + * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12), +c * ncmid(iv,ip)) + * ncmid(iv,ip),btest(icrdat(icrd),31)) + notexq = notexq(1:lnote)//nosymq + crdacc = .true. + else + notexq = nosymq + end if + lnote = lnote+lsym +c +c Get note name (again if accid, due to possible octave jump) +c + call notefq(noteq,lnoten,nolev,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) +c +c Put in note name +c + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + if (btest(icrdat(icrd),25)) then +c +c Arpeggio signal +c +c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout) + end if + call addstr(notexq,lnote,soutq,lsout) + if (ismidi) then +c +c Here is where we collect MIDI pitch info for the chord note. By checking +c notmain, addmidi(...) knows to just compute the +c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() +c for MAIN note, will put in note codes for all chord notes + main note. +c + kv = 1 + if (ivx .gt. iv) kv=2 + nmidcrd = nmidcrd+1 + if (nmidcrd .gt. 20) then + print* + print*,'21 chord notes is too many for midi processor' + call stop1() + end if +c +c Use original saved pitch level, unaltered by 2nds logic. +c +c call addmidi(midchan(iv,kv),nolevo, + call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), + * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) + end if +5 continue + notmain = .false. + return + end + subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv, + * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout) + parameter (nm=24) +c +c Inputs are array *elements* except ihornb,nornb,ulq +c + common /commus/ musize,whead20 + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,beamon,upstem,nostem + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 udqq,chax,ulq(nm,9) + character*4 dynstrq + character*5 numpq + character*48 dyntablq,tempq + character*79 notexq + character*80 soutq + integer*4 ihornb(nm,24),nornb(nm),idynn(10) + data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/ + numdyn = 0 +c +c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values +c in idynn(1...4) +c + do 1 idyn = 1 , ndyn +c ivxtent = iand(idyndat(idyn),15) + ivxtent = iand(idyndat(idyn),15) + * +16*igetbits(idynda2(idyn),1,10) + if (ivxtent .eq. ivx) then + iptent = igetbits(idyndat(idyn),8,4) + if (iptent .eq. ip) then + numdyn = numdyn+1 + idynn(numdyn) = idyn + else if (iptent .gt. ip) then +c +c I don't think there are any more possible for this ivx,ip, so exit loop +c + go to 2 + end if +c else if (ivxtent .gt. ivx) then +c go to 2 + end if +1 continue +2 continue +c +c At this point there is a list of idyn's in idynn(1...numdyn) +c Compute level, and stem-dir'n-based horizontal tweaks +c + hoffsd = 0. +c +c Set upstem to false as default +c + upstem = .false. + if (btest(irest,0)) then +c +c It's a rest. Assume it doesn't go below the staff +c + lbot = ncm-4 + else if (.not.beamon) then + if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + if (.not.btest(ipl,10)) then + lbot = min(nolev-7,ncm-4) + else + lbot = min(minlev-7,ncm-4) + end if + end if + else + if (ulq(ivx,ibmcnt) .eq. 'u') then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + lbot = ihornb(ivx,nornb(ivx))+1 + if (lbot .eq. 1) then +c +c Kluge for non-beamed, down xtup, for which ihorb was never set. +c Assumes stem is shortened. +c + lbot = nolev-5 + end if + nornb(ivx) = nornb(ivx)+1 + end if + end if + lbot = lbot-5 + jtxtdyn1 = 1 +c +c Now ready to loop over current dyn's +c + do 3 icntdyn = 1 , numdyn + idynd = idyndat(idynn(icntdyn)) + idynd2 = idynda2(idynn(icntdyn)) + idno = igetbits(idynd,4,12) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynd2,1,10) +c +c Build the command into notex in stages. Insert name & rq'd args in order: +c +c Command name +c hpstrt, hpcend, hpdend, pmxdyn +c ivx +c X X X +c level +c X X X +c hoff +c X X X X +c d-mark +c X +c + if (idno .eq. 0) then +c +c Text-dynamic +c + notexq = chax(92)//'txtdyn' + lnote = 7 + else if (idno .le. 12) then +c +c Letter-group +c + notexq = chax(92)//'pmxdyn' + lnote = 7 + else if (fontslur) then + lnote = 7 + if (idno .eq. 13) then +c +c Start a hairpin +c + notexq = chax(92)//'hpstrt' + else if (idno .eq. 14) then +c +c End crescendo +c + notexq = chax(92)//'hpcend' + else +c +c End decrescendo +c + notexq = chax(92)//'hpdend' + end if + else +c +c Postscript hairpins +c + lnote = 7 + if (idno .eq. 13) then + notexq = chax(92)//'Icresc' + else if (idno .eq.14) then + notexq = chax(92)//'Idecresc' + lnote = 9 + else + notexq = chax(92)//'Tcresc' + end if + end if + if (idno .ge. 13) then +c +c Put in voice number +c + if (ivx .le. 9) then + notexq = notexq(1:lnote)//char(48+ivx) + lnote = lnote+1 + else if (ivx .le. 19) then + notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}' + lnote = lnote+4 + end if + end if +c +c Begin setting level +c + lbot1 = lbot + if (idno.gt.0 .and. idno.le.5) then +c +c All letters are short so raise a bit. +c + lbot1 = lbot1+1 + else if (idno .ge. 13) then + lbot1 = lbot1+2 + end if +c +c Convert so reference is bottom line +c + lbot1 = lbot1-ncm+4 + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. Save level and user-tweak before applying user tweak. +c + levdsav(ivx) = lbot1 + levhssav(ivx) = 0 + if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17) + else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then +c +c Hairpin end; Compare level with saved start level before user-tweaks +c + lbot1 = min(lbot1,levdsav(ivx)) +c +c Save pre-tweak level +c + lpretweak = lbot1 + end if +c +c Check for user-defined vertical tweak +c + if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17) +c +c Now horizontal stuff +c + hoff = hoffsd +c +c Some special horizontal tweaks +c + if (upstem .and. idno.gt.0 .and. + * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4 +c +c User-defined tweaks +c + if (btest(idynd2,0)) + * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1 + if (numdyn .gt. 1) then +c +c Horizontal-interaction-based tweaks. +c +c Cases: +c numdyn type1 type2 type3 data used +c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) +c 2 hrpnend wrd-grp - ivowg,hoh2 +c 2 hrpnend hrpnstrt - hoh2h1(1...2) +c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 +c + if (idno.gt.0 .and. idno.le.12) then +c +c Word-group, may need vertical tweak to line up. +c + lbot1 = lbot1+ivowg(idno) +c +c Protecting against hp start-stop on same note +c + else if (((fontslur.and.idno.ge.14).or.idno.eq.15) + * .and. icntdyn.lt.numdyn) then +c +c Hairpin ending, check next type +c + if ((fontslur .and. + * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. (.not.fontslur .and. + * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. + * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14)))) + * then +c +c Hairpin end then hairpin start, no words, (remember dealing with end now) +c + hoff = hoff+hoh2h1(1) + else +c +c Hairpin end then word-group, need idno for w-g to set hp offset +c + hoff = hoff + + * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12)) + end if +c +c Protecting against hp start-stop on same note +c + else if (icntdyn.gt.1 .and. idno.gt.0 .and. + * ((fontslur.and.idno.lt.14).or. + * (.not.fontslur.and.idno.lt.15))) then +c +c Hairpin start, check prior type +c + if ((fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14) + * .or. + * (.not.fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15)) + * then +c +c Hairpin end then hairpin start, (remember dealing with start now) +c + hoff = hoff+hoh2h1(2) + else +c +c Hairpin start after word-group, need idno for w-g to set hp offset +c + hoff = hoff+ + * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12)) + end if + end if + end if +c +c End of if-block for 2- or 3-way interactions. +c + if ((.not.fontslur) .and. idno.ge.13) +c +c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width +c + * hoff = (hoff+.5)*6./2.5 +c +c Position corrections all done now. Put in the level. +c + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. +c + if (.not.fontslur) then +c +c Postscript hairpin start...inset placeholder for start level. + + notexq = notexq(1:lnote)//'{ }' + lnote = lnote+5 + end if + else +c +c Insert actual level in all cases except hairpin start +c Create string with level in it +c + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Level has now been computed and stored in numpq +c Append the level +c + notexq = notexq(1:lnote)//numpq(1:lnumpq) + lnote = lnote+lnumpq + end if + if (abs(hoff) .lt. .001) then +c +c No horiz offset +c + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else +c +c Horizontal tweak +c + lform = lfmt1(hoff) + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')hoff + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + if (idno .eq. 0) then +c +c text-dynamic. Find the string and append it +c + do 4 jtxtdyn = jtxtdyn1 , ntxtdyn +c ivxip = ivx+16*ip + ivxip = ivx+32*ip + if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5 +4 continue + call printl('Abnormal stop in putdyn') + call stop1() +5 continue + ltxtdyn = lenstr(txtdynq(jtxtdyn),128) +c +c Font size based on musicsize +c + if (musize .eq. 20) then + notexq = notexq(1:lnote)//'{'//char(92)//'medtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 16) then + notexq = notexq(1:lnote)//'{'//char(92)//'normtype' + * //char(92)//'it ' + lnote = lnote+14 + else if (musize .eq. 24) then + notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 29) then + notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' + * //char(92)//'it ' + lnote = lnote+13 + end if + notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn) + * //'}' + lnote = lnote+ltxtdyn+1 +c +c Reset jtxtdyn1 just in case >1 txtdyn on same note. +c + jtxtdyn1 = jtxtdyn+1 + else if (idno .le. 12) then +c +c Letter-group dynamic. Append the letter-group command +c + id = 4*idno + dynstrq = dyntablq(id-3:id) + id = lenstr(dynstrq,4) + notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id) + lnote = lnote+1+id + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) + if ((.not.fontslur).and.idno.eq.15) then +c +c PS slurs on, hairpin is ending. Go back and set height at beginning. +c Add user-defined tweak to default level +c + lbot1 = lpretweak+levhssav(ivx) + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Construct string to search backwards for placeholder +c + if (ivx .le. 9) then + tempq = 'cresc'//char(48+ivx)//'{ }' + ltemp = 11 + else if (ivx .le. 19) then + tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }' + ltemp = 14 + else + tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }' + ltemp = 14 + end if + write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + call backfill(11,tempq,ltemp, + * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq) + end if +3 continue +c +c Shrink arrays, decrease ndyn 111109 +c + do 6 icntdyn = numdyn, 1 , -1 + do 7 jdyn = idynn(icntdyn) , ndyn-1 + idyndat(jdyn) = idyndat(jdyn+1) + idynda2(jdyn) = idynda2(jdyn+1) +7 continue + ndyn = ndyn-1 +6 continue + end + subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl, + * farend, + * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq) +c +c ip will be one LESS than current note, for way-after's before bar-end, +c It is only used to find ig. +c ig is returned to makeabar in case there's a slur that needs to be ended +c + parameter (nm=24) + logical beamon,stemup + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft, + * normsp,farend,fontslur,WrotePsslurDefaults + real*4 ptgr(37) + character*80 soutq + character*128 litq + character*79 notexq + character*20 voltxtq + character*10 figq + character*8 noteq,noteqGA + character*3 acsymq + character*1 sq,chax,udqq,ulq(nm,9) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + sq = chax(92) + isgaft = btest(ipl,29) + iswaft = btest(ipl,31) + normsp = .not. isgaft +c +c Find ig. +c + do 120 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121 +120 continue + print*,'Problem finding grace index in dograce' + stop +121 continue + ngs = ngstrt(ig) + mg = multg(ig) + wheadpt1 = wheadpt*fullsize(ivx) +c +c For way-after-graces at end of bar, must set the octave. +c + if (farend) then + noctup = 0 + if (ncm .eq.23) noctup = -2 + end if + if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then + if (listslur .eq. 16777215) then + print* + print*,'You defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Slur on fore-grace. Get index of next slur not in use, from 23 down. +c + ndxslur = log2(16777215-listslur) + + end if + if (nng(ig) .eq. 1) then +c +c Single grace. +c + if (normsp) then +c +c Anything but GA +c + call addstr(sq//'shlft',6,soutq,lsout) + niptgr = nint(ptgr(ig)) +c +c Empirical tweak for postscript. +c +C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) +c++ + if (niptgr .lt. 10) then + call addstr(chax(48+niptgr)//'{',2,soutq,lsout) + else if (niptgr .lt. 100) then + write(notexq(1:2),'(i2)')niptgr + call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout) + else + print*, + * 'Call Dr. Don if you really want grace note group > 99 pt' + stop + end if + else + call addstr(sq//'gaft{1.5}{',11,soutq,lsout) +c +c GA. Compute aftshft, for later use. +c + aftshft = grafac + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac + aftshft = aftshft*wheadpt + end if + if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then +c +c Start slur on pre-grace. No accounting needed since will be ended very soon. +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Start Postscript slur. +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print slur number, 23-ndxslur +c + lnote = 0 + if (23-ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = chax(71-ndxslur) + lnote = 1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = '{1'//chax(61-ndxslur)//'}' + lnote = 4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = 4 + end if +c if (11-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, +c * soutq,lsout) +c else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), +c * 4+lnoten,soutq,lsout) +c end if + call addstr(notexq(1:lnote)//noteq(1:lnoten), + * lnote+lnoten,soutq,lsout) + if (.not.fontslur) then +c +c Horizontal tweaks for postscript slur on single grace +c + stemup = .true. + if (upg(ig)) then +c +c Check for up-grace + down stem. Get stem direction +c + if (.not.beamon) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev,ncmidx, + * islur,nvmx,ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. tnote.gt.63 + end if + if (stemup) then + call addstr('{-.3}',5,soutq,lsout) + else + call addstr('{-.8}',5,soutq,lsout) + end if + end if + end if + if (naccg(ngs) .gt. 0) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c +c Save for checking octave shifts in GA +c + if (isgaft) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc)// + * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if + if (slashg(ig)) then + notexq = sq//'grc' + lnote = 4 + else if (mg .eq. 0) then + notexq = sq//'zq' + lnote = 3 + else + notexq = sq//'zc' + do 61 i = 2 , mg + notexq = notexq(1:i+1)//'c' +61 continue + lnote = mg+2 + end if + if (upg(ig)) then + notexq = notexq(1:lnote)//'u' + else + notexq = notexq(1:lnote)//'l' + end if + call addstr(notexq,lnote+1,soutq,lsout) + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c + if (isgaft .and. naccg(ngs).eq.0) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call addstr(noteq,lnoten,soutq,lsout) + if (slashg(ig)) call addstr(sq//'off{-'//sq// + * 'noteskip}',16,soutq,lsout) +c +c Above code needed since slashg causes spacing +c + if (slurg(ig) .and. (iswaft.or.isgaft)) then +c +c Terminate slur on single after-grace +c +c ndxslur = igetbits(ipl,4,23) + ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ngs),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +cc Print 11-ndxslur +c Print 24-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten), + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if + slurg(ig) = .false. + listslur = ibclr(listslur,ndxslur) + end if + call addstr('}',1,soutq,lsout) +c +c+++ Try to fix loss of octave with single gaft +c +c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', +c * 13+lnoten,soutq,lsout) + if (isgaft) then + itrans = 0 + do 1 i = 1 , lnotenGA + if (noteqGA(i:i) .eq. chax(39)) then + itrans = itrans+7 + else if (noteqGA(i:i) .eq. chax(96)) then + itrans = itrans-7 + end if +1 continue + if (itrans. eq. -14) then + call addstr(sq//'advance'//sq//'transpose-14',21, + * soutq,lsout) + else if (itrans .eq. -7) then + call addstr(sq//'advance'//sq//'transpose-7',20, + * soutq,lsout) + else if (itrans .eq. 7) then + call addstr(sq//'advance'//sq//'transpose7',19, + * soutq,lsout) + else if (itrans .eq. 14) then + call addstr(sq//'advance'//sq//'transpose14',20, + * soutq,lsout) + end if + end if + else +c +c Multiple grace. Put in literally. Compute beam stuff +c + sumx = 0. + sumy = 0. + sumxy = 0. + sumxx = 0. + sumyy = 0. + x = 0. + do 118 ing = ngs , ngs+nng(ig)-1 + if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac + y = nolevg(ing) + sumx = sumx + x + sumy = sumy + y + sumxy = sumxy + x*y + sumxx = sumxx + x*x + sumyy = sumyy + y*y + x = x+emgfac +118 continue + delta = nng(ig)*sumxx-sumx*sumx + em = (nng(ig)*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*gslfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/gslfac*sumx)/nng(ig) + nolev1 = nint(beta) +c +c Back up +c + notexq = sq//'settiny'//sq//'off{' + if (normsp) then + write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig) + call addstr(notexq(1:18)//'pt}',21,soutq,lsout) + finalshift = ptgr(ig) + else + aftshft = wheadpt*1.33 + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5 + write(notexq(14:17),'(f4.1)')aftshft + call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout) + end if +c +c Start the beam +c + notexq = sq//'ib' + do 119 ing = 2 , mg + notexq = notexq(1:ing+1)//'b' +119 continue + if (upg(ig)) then + notexq = notexq(1:mg+2)//'u' + else + notexq = notexq(1:mg+2)//'l' + end if + notexq = notexq(1:mg+3)//'0' +c +c Get starting note for beam +c + call notefq(noteq,lnoten,nolev1,ncm) + call addstr(notexq(1:mg+4)//noteq(1:lnoten), + * mg+4+lnoten,soutq,lsout) +c +c Put in the slope +c + if (islope .ge. 0) then + call addstr(chax(48+islope),1,soutq,lsout) + else + call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout) + end if +c +c Start a slur on multiple fore-grace +c + if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Need a tweak for postscript slur +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print 11-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten, + * soutq,lsout) + else if (23-ndxslur .lt. 2) then + call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if +c +c Put in tweak for postscript slur +c + if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout) + end if +c +c Put in first note. Call notefq again in case octave changed +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (naccg(ngs) .eq. 0) then + notexq = sq//'zqb0'//noteq(1:lnoten) + lnote = 5+lnoten + else + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten) + lnote = 4+lacc+lnoten + call notefq(noteq,lnoten,nolevg(ngs),ncm) + notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten) + lnote = lnote+5+lnoten + end if + call addstr(notexq,lnote,soutq,lsout) + do 127 ing = ngs+1 , ngs+nng(ig)-1 +c +c Skip +c + ptoff = wheadpt1*emgfac + if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac + if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff + notexq = sq//'off{' + write(notexq(6:8),'(f3.1)')ptoff + if (normsp) finalshift = finalshift-ptoff + call addstr(notexq(1:8)//'pt}',11,soutq,lsout) + if (ing .eq. ngs+nng(ig)-1) then +c +c Terminate beam if needed +c + if (upg(ig)) then + call addstr(sq//'tbu0',5,soutq,lsout) + else + call addstr(sq//'tbl0',5,soutq,lsout) + end if +c +c Terminate after slur if needed +c + if ((isgaft.or.iswaft) .and. slurg(ig)) then +c if (iswaft) ndxslur = igetbits(ipl,4,23) + if (iswaft) ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +c Print 11-ndxslur +cc Print 23-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + end if +c +c Stop slur terminator after exit from this subroutine +c + listslur = ibclr(listslur,ndxslur) + slurg(ig) = .false. + end if + end if +c +c Accidental if needed +c + if (naccg(ing).gt.0) then + call notefq(noteq,lnoten,nolevg(ing),ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ing),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc) + * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if +c +c Put in the (beamed) grace note +c + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten, + * soutq,lsout) +127 continue +c +c Terminate the grace +c +c notexq = sq//'normalnotesize'//sq//'off{' +c lnote = 20 +c notexq = '}'//sq//'off{' +c lnote = 6 + notexq = sq//'off{' + lnote = 5 + ptoff = wheadpt*emgfac + if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17)) + * ptoff = ptoff+wheadpt*accfac + if (isgaft .and. .not.iswaft) then + notexq = notexq(1:5)//'-' + lnote = 6 + ptoff = aftshft + end if + if (normsp) ptoff = finalshift + if (ptoff .lt. 9.95) then + write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff + lnote = lnote+3 + else if (ptoff .lt. 99.95) then + write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff + lnote = lnote+5 + end if + call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout) + if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout) + call addstr(sq//'resetsize',10,soutq,lsout) + end if + return + end + subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip, + * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur, + * ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. +c 12 May 2002 Create this subroutine to isolate postscript slurs/ties. +c Always set \Nosluradjust\Notieadjust +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd, + * settie,fontslur,pstie,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. +c 18 int(ndxslur/16), ditto. So this allows ndxslur>15. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +c +c Bits in isdat4 Only used for linebreak slurs +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +c +c In listslur bit ib is on if slur index ib is in use, ib=0-13. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + pstie = btest(isdat2(isdat),3) .or. idcode.eq.1 + if (btest(isdata,11)) then +c +c Turnon +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then +cc +cc Note was a rest, cannot start slur on rest. +cc +c print* +c call printl('Cannot start slur on a rest') +c call stop1() +c nolevs = ncm+5 +c end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Set level for slur starting on rest +c + if (nolevs.eq.0 .or. nolevs.gt.60) then + if (slurudq .eq. 'u') then + nolevs = ncm+2 + else + nolevs = ncm-2 + end if + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from 12 down +c + ndxslur = log2(16777215-listslur) +c write(*,'()') +c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c write(*,'(10x,B24)')listslur +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff+8 + else + ihoff = ihoff+2 + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + notexq = chax(92) + lnote = 1 +c +c Check for local adjustment default changes +c + if (btest(isdat2(isdat),26)) then + notexq = chax(92)//'sluradjust'//chax(92) + lnote = 12 + else if (btest(isdat2(isdat),27)) then + notexq = chax(92)//'nosluradjust'//chax(92) + lnote = 14 + else if (btest(isdat2(isdat),28)) then + notexq = chax(92)//'tieadjust'//chax(92) + lnote = 11 + else if (btest(isdat2(isdat),29)) then + notexq = chax(92)//'notieadjust'//chax(92) + lnote = 13 + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = notexq(1:lnote)//'islur'//slurudq + lnote = lnote+6 + else + notexq = notexq(1:lnote)//'is'//slurudq + lnote = lnote+3 + end if +c +c Prepend postscript tie switch +c + if (pstie) then + notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote) + lnote = lnote+10 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c +c noteq = notexq +c notexq = chax(92)//'dotted'//noteq + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c +c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + islhgt = nolevs+iupdn+ivoff + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Store height and staff mid level for use with LineBreakTies +c + call setbits(isdat3(isdat),8,14,islhgt) + call setbits(isdat3(isdat),8,22,ncm) +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then +c levson(midchan(iv,kv)) = nolev + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue +c +c Bugfix 070901 for slur ending on rest in 2-voice staff +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then + if (nolevs.le.2 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then +c +c Deal with \curve or \midslur. isdat is ending, j is start. +c + if (btest(isdat3(isdat),0)) then + imid = igetbits(isdat3(isdat),6,2)-32 + else + imid = igetbits(isdat3(j),6,2)-32 + end if +c +c Postscript slurs, and \midslur adjustment is needed. Invoke macro +c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: +c Abs(imid) Postscript slur type +c 1 f +c 2-3 default +c 4 h +c 5 H +c 6+ HH +c + call addstr(chax(92)//'psforts'// + * chax(48+min(abs(imid),6)),9,soutq,lsout) + end if +c +c Shift slur ending for stem on any note? +c + if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff-8 + else + ihoff = ihoff-3 + end if + end if + if (iscrd) then +c +c Shift termination for shifted notehead? +c + if (btest(isdat2(isdat),1)) then +c +c Left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c +c Switch to postscript tie +c + if (pstie) then + notexq = chax(92)//'tieforts'//notexq(1:lnote) + lnote = lnote+9 + end if +c +c Print 13-ndxslur +c 5/25/08 Allow 14 slurs +c + if (23-ndxslur .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + end if + ivoff = ivoff+ivoffinc + end if + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then + if (idcode .eq. is2n1) is1n1=0 + end if + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihoff .ne. 0) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Clear the bit from list of slurs in use +c + listslur = ibclr(listslur,ndxslur) +c +c Zero out the entire strings for start and stop +c + isdata = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + isdat4(isdat) = 0 + isdat1(j) = 0 + isdat2(j) = 0 + isdat3(j) = 0 + isdat4(j) = 0 +c +c Set midi info for slur ending +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then + icm = midchan(iv,kv) + if (slmon(icm)) then + if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then +c +c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. +c + levsoff(icm) = nolevs + settie = .true. + else + levsoff(icm) = 0 + levson(icm) = 0 + slmon(icm) = .false. + end if + end if + end if + end if + isdat1(isdat) = isdata + end if +1 continue +c +c Clear and collapse the slur data list +c + numdrop = 0 + do 2 isdat = 1 , nsdat + if (isdat1(isdat) .eq. 0) then + numdrop = numdrop+1 + else if (numdrop .gt. 0) then + 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 + end if +2 continue + nsdat = nsdat-numdrop +c call report(nsdat,isdat1,isdat2) + return + end + subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv, + * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. (5/26/02) for non-ps slurs only +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove, + * settie,fontslur,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c +c In listslur bit ib is on if slur index ib is in use, ib=0-23. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (btest(islur,1)) then +c +c 't'-slur (idcode=1) somewhere on this note. Find it, check height against +c 's'-slur (idcode=32) +c + sfound = .false. + tfound = .false. + tmove = .false. + do 5 isdat = 1 , nsdat + if (iv .eq. igetbits(isdat1(isdat),5,13) .and. + * ip .eq. igetbits(isdat1(isdat),8,3) .and. + * kv .eq. igetbits(isdat1(isdat),1,12)+1) then + if (.not.tfound) then + tfound = igetbits(isdat1(isdat),7,19).eq.1 + if (tfound) then + nolevt = igetbits(isdat2(isdat),7,19) + isdatt = isdat + if (sfound) go to 6 + end if + end if + if (.not.sfound) then + sfound = igetbits(isdat1(isdat),7,19).eq.32 + if (sfound) then + nolevs = igetbits(isdat2(isdat),7,19) + isdats = isdat + if (tfound) go to 6 + end if + end if + end if +5 continue +c +c Will come thru here if there is a t with no s, so comment out the following +c print*,'Did not find s+t-slurs in doslur' +c +6 continue + if (sfound .and. tfound) + * tmove = nolevs.eq.nolevt .and. +c +c Check if 2 starts or two stops +c + * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or. + * (.not.btest(isdat1(isdats),11).and. + * .not.btest(isdat1(isdatt),11)) ) +c +c This is a flag for later changing slur level, after we know slur dir'n. +c + end if + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + if (btest(isdata,11)) then +c +c Turnon, +c + 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() + end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (idcode.eq.1 .and. tmove) then + iupdn = 1 + if (slurudq .eq. 'd') iupdn = -1 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twenty-fifth slur, one too many!' + write(15,'(/,a)') + * 'You2 defined the twenty-fifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from ? down +c + ndxslur = log2(16777215-listslur) +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) + * ihoff = ihoff+8 + if (btest(isdat2(isdat),3)) then +c +c Tie spacing, (slur start) +c + if (slurudq.eq.'d') then + ivoff = ivoff+1 + ihoff = ihoff+8 + else if (slurudq.eq.'u') then + ivoff = ivoff-1 + if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8 +c +c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') +c + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = chax(92)//'islur'//slurudq + lnote = 7 + else + notexq = chax(92)//'is'//slurudq + lnote = 4 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c + noteq = notexq + notexq = chax(92)//'dotted'//noteq + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. idcode.eq.32) then + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue + if (nolevs.eq.0 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0)) then +c +c Deal with \curve or \midslur +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Remember, only dealing with non-ps slurs +c +c Who knows where the following line came from. Removed it 6/30/02 to +c restore behavior of non-ps slurs to old way +c if (slurudq .eq. 'd') imid = -imid +c 3/8/03 added the following +c + if (slurudq .eq. 'd') imid = -abs(imid) +c + if (btest(isdat3(isdat),1)) then + notexq = chax(92)//'curve' + lnote = 6 + else + notexq = chax(92)//'midslur' + lnote = 8 + end if + if (imid.lt.0 .or. imid.gt.9) then +c +c Need brackets +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (imid .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')imid + lnote = lnote+3 + else if (imid.lt.0 .or. imid.gt.9) then + write(notexq(lnote+1:lnote+2),'(i2)')imid + lnote = lnote+2 + else + write(notexq(lnote+1:lnote+1),'(i1)')imid + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else +c +c 1= 0 . +c Xtups are irrelevant here since they are already all in forced beams. +c Will update itnow by nodur at the END of this loop +c + ip = ip+1 + go to 11 + end if + nreal = nreal+1 + nodue(nreal) = nodur(ivx,ip) + short(nreal) = nodue(nreal).lt.16 .and. + * .not.btest(irest(ivx,ip),0) +c +c Rule out notes that have 'alone'-flag set +c + * .and..not.btest(islur(ivx,ip),18) + ipr(nreal) = ip + itr(nreal) = itnow + if (nodue(nreal) .eq. 1) then +c +c 64th gap +c + if (mod(itnow,2) .eq. 0) then +c +c Start of 32nd gap, lump with following note +c + ip = ip+1 + nodue(nreal) = 1+nodur(ivx,ip) + itnow = itnow+nodue(nreal) + else +c +c End of 32nd gap, lump with preceeding note +c + nreal = nreal-1 + nodue(nreal) = 1+nodue(nreal) + itnow = itnow+1 + end if + else + itnow = itnow+nodur(ivx,ip) + end if + go to 1 +9 continue + ir1 = 1 + itseg = lenbar/ibmrep + do 13 irep = 1 , ibmrep +c +c Set bitmaps for all shorts neighbored by a short. Each bit represents a +c span of 32nd note. maps, mapm, mape record start, full duration, and end +c of consecutive span of beamable (<1/4) notes. +c + maps = 0 + mapm = 0 + mape = 0 + itend = itseg*irep + itoff = itend-itseg + do 2 ir = ir1 , nreal + it2 = itr(ir)+nodue(ir)-2 + if (it2 .ge. itend) then + ir1 = ir + go to 14 + end if +c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal + if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or. + * (ir.lt.nreal.and.short(ir+1)))) then + ib1 = (itr(ir)-itoff)/2 + ib2 = (it2-itoff)/2 + if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or. + * min(ib1,ib2).lt.0) return +c +c Must have an odd number obe beats in a long bar. Auto-beam won't work +c + nip1(ib1) = ipr(ir) + nip2(ib2) = ipr(ir) +c +c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip +c + maps = ibset(maps,ib1) + mape = ibset(mape,ib2) + do 3 ib = ib1 , ib2 + mapm = ibset(mapm,ib) +3 continue + end if +2 continue +14 continue + if (mapm .eq. 0) go to 13 +c +c Zero out bits from forced beams +c + maps = iand(maps,not(mapfb(irep))) + mapm = iand(mapm,not(mapfb(irep))) + mape = iand(mape,not(mapfb(irep))) +c +c Compare map with template. +c + do 4 it = 1 , nummask(ibmtyp) + masknow = mask(it,ibmtyp) + if (iand(masknow,mapm) .eq. masknow) then +c +c Find least significant bit in the mask to check start time +c + mtemp = masknow + maskm = masknow + do 5 is1 = 0 , 47 + if (iand(1,mtemp) .eq. 1) go to 6 + mtemp = ishft(mtemp,-1) +5 continue +6 continue + if (iand(ishft(1,is1),maps) .eq. 0) go to 4 +c +c is1 is the bit where the beam starts. Continue shifting to +c find most significant bit in the mask to check ending time +c + do 7 is2 = is1 , 47 + mtemp = ishft(mtemp,-1) + if (iand(1,not(mtemp)) .eq. 1) go to 8 +7 continue +8 continue +c +c is2 is now the bit on which the beam ends. +c + if (iand(ishft(1,is2),mape) .eq. 0) go to 4 +c +c Did we pick out a single note from the middle of a longer sequence? +c + if (nip1(is1) .eq. nip2(is2)) go to 4 +c +c We almost have a beam. Check equality of notes if needed. +c + if (eqonly(it,ibmtyp)) then + do 10 ip = nip1(is1) , nip2(is2) + if (nodur(ivx,ip) .ne. 8) then +c +c There is a non-1/8th note in this beam. Exit if not 2 quarters +c + if (is2-is1 .ne. 15) go to 4 +c +c Beam is 2 quarters long. Check if can split in half. +c + ithalf = 0 + do 20 iip = nip1(is1) , nip2(is2) + ithalf = ithalf+nodur(ivx,iip) + if (ithalf .gt. 16) go to 4 + if (ithalf .eq. 16) go to 21 +20 continue + print*,'Problem in findbeam, please call Dr. Don' + go to 4 +21 continue +c +c Otherwise, split in half by keeping only the first half. Other half will +c be picked up later, assuming masks are listed longest first. +c + is2 = is1+7 +c +c Reset maskm (since only used part of mask), used later to zero out +c bits that contain beams +c + maskm = 0 + do 15 is = is1 , is2 + maskm = ibset(maskm,is) +15 continue + go to 16 + end if +10 continue + end if +16 continue +c +c This is a beam. If last "effective" ends on odd 64th, add 1 more +c +c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) +c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then + if (abs(amod(to(ipl2(ivx,nip2(is2))) + * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then + nip2(is2) = nip2(is2)+1 + end if + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) + call logbeam(numnew,nip1(is1),nip2(is2)) +c +c Zero out the appropriate bits so these notes don't get used again +c + mapm = iand(mapm,not(maskm)) + if (mapm.eq.0) go to 13 + maps = iand(maps,not(maskm)) + mape = iand(mape,not(maskm)) + end if +4 continue +13 continue + return + end + subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0) + parameter (nkb=3999,maxblks=4000) +c +c Compute an exponent eonk for use in the "flattened" formula for elemskips +c vs time. We must solve the eqution f = 0. Initial quess is eonk0. +c + logical gotclef + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + common /comeon/ eonk,ewmxk + eonk = eonk0 + niter = 0 +1 continue + ewmxk = f1eon(dtmax)**eonk + niter = niter+1 + esum = 0. + desum = 0. + do 2 iptr = nptr1 , nptr2 + targ = durb(iptr)/sqzb(iptr) + esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ) + detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ) + desum = desum+nnpd(iptr)*sqzb(iptr)*detarg +2 continue + f = wovera*feon(dtmin)-xelsk-esum + fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin) + * -desum + if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then + call printl( + * 'Error in findeonk. Please send source to Dr. Don') + eonk = 0. + ewmxk = 1. + return + end if + dsoln = -f/fp + if (abs(dsoln) .lt. .1*tol) return +c +c Not converged yet, try again +c + eonk = eonk+dsoln + go to 1 + end + function fnote(nodur,ivx,ip,nacc) +c +c This return the real duration of a note +c + parameter (nm=24) + integer*4 nodur(nm,200),nacc(nm,200) + logical btest + ipback = ip + if (nodur(ivx,ip) .gt. 0) then + if (ip .gt. 1) then +c +c Check if this is last note of xtup +c + if (nodur(ivx,ip-1).eq.0) then + ipback = ip-1 + go to 2 + end if + end if + fnote = nodur(ivx,ip) + return + end if +2 continue +c +c Count back to prior non zero note. Start at ip to avoid neg index if ip=1. +c Count how many doubled xtups notes there are from ip-1 to first note. +c + ndoub = 0 + do 1 ip1m1 = ipback , 1 , -1 + if (nodur(ivx,ip1m1) .gt. 0) go to 4 + if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1 +1 continue +4 continue +c +c count forward to next non-0 nodur. Start at ip in case last note of xtup. +c + do 3 iip = ip , 200 +c +c Count doubled xtup notes from ip to end. +c + if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1 + if (nodur(ivx,iip) .gt. 0) then +c fnote = nodur(ivx,iip)/float(iip-ip1m1) + fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub) + if (btest(nacc(ivx,ip),18)) then + fnote = 2*fnote + else if (btest(nacc(ivx,ip),27)) then + fnote = 1.5*fnote + else if (ip .gt. 1) then + if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote + end if + return + end if +3 continue + print*,' ' + call printl + * ('Probable misplaced barline or incorrect meter, stopping') +c call printl('Program error in fnote, send source to Dr. Don') + call stop1() + end + subroutine g1etchar(lineq,iccount,charq) + parameter(nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,issegno,isheadr,isvolt,fbon + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + character*1 charq + character*128 lineq,lnholdq +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not.endmac) then + iccount = 0 + if (.not.mplay) nline = nline+1 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return + end + subroutine g1etnote(loop,ifig,optimize,fulltrans) + parameter (nm=24,nkb=3999,mv=24576,maxblks=4000) + character*1 chax + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend, + * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt, + * stickyS + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + logical mrecord,mplay,endmac,shifton,gotclef,optimize + character*128 lineq,lnholdq + character*1 charq,dotq,dumq,durq,charlq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical novshrinktop,upslur,fontslur,ztrans, + * WrotePsslurDefaults,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + character*51 literq(3) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + common /comsize/ isize(nm) + data literq + * /'Literal TeX string cannot start with 4 backslashes!', + * 'TeX string must have <129 char, end with backslash!', + * 'Type 2 or 3 TeX string can only start in column 1!'/ + cdot = .false. +1 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') charlq = charq + if (lastchar) then + if (index('/%',charlq) .eq. 0) then + print* + print*,'WARNING:' + print*,'Last non-blank character is "',charlq,'", not "/,%"' + print*,'ASCII code:',ichar(charlq) + write(15,'(/a)')'Last non-blank character is "'//charlq// + * '", not "/,%"' + write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq) +c +c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. +c + ilbuf = ilbuf-1 + lbuf(ilbuf) = lbuf(ilbuf)+2 + bufq = bufq(1:ipbuf)//' /' + write(15,*)'appending /' + print*,'appending /' + lineq = lineq(1:iccount)//' /' + lastchar = .false. + go to 1 + end if + return + end if + if (charq .eq. ' ') then + go to 1 + else if (charq.eq.'%' .and. iccount.eq.1) then + iccount = 128 + go to 1 +c +c Replacement 1/22/12 since gfortran 4.7 with -O was choking here! +c +c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + else if (index('abcdefg',charq).gt.0 .or. + * charq.eq.'r') then +c +c This is a note/rest. gotclef is only used for checking for clef before "/" +c + if (cdot) go to 28 + if (gotclef) gotclef=.false. + idotform = 0 + numnum = 0 + plusmin = .false. +28 nnl(ivx) = nnl(ivx)+1 + if (nnl(ivx) .gt. 200) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>200 notes in line of music. Use smaller blocks!') + call stop1() + end if + dotq = 'x' +c +c Check if this is 'r ' and previous note was full-bar-pause +c + fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and. + * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar +2 call g1etchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + if (charq .eq. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one digit allowed after rest symbol "r"!') + call stop1() + end if + numnum = 2 + if (plusmin) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>2 digits in note symbol!') + call stop1() + end if + else if (durq.eq.'d') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then + iddot = 1 + iccount = iccount+1 +c +c Since we flow out, double dots won't work with other dot options +c + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, provided a number follows. +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then +c +c Backup, exit the loop normally +c + iccount = iccount-2 + go to 2 + end if + call readnum(lineq,iccount,dumq,fnum) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after 2nd +/- (shift dot)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + iccount = iccount-1 + end if + go to 2 + else if (index('<>',durq) .gt. 0) then +c +c Accidental shift +c +c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, +c * 'Expected "f", "s", or "n" before "<" or ">"!') + * 'Expected "f", "s", "n" or "A" before "<" or ">"!') + call stop1() + end if + ipm = 1 + if (durq .eq. '<') ipm=-1 + call g1etchar(lineq,iccount,durq) + if (index('123456789.0',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after (accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horizontal accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else if (index('+-',durq) .gt. 0) then + if (charq .ne. 'r') then + if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then + ipm = 1 + if (durq .eq. '-') ipm=-1 + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .gt.0) then +c +c This may be start of accidental shift, but may be octave jump; then duration +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .gt. 0) then +c +c This is an accid shift since there's a 2nd consecutive signed number. +c Check size of 1st number. +c + if (fnum .gt. 30.5) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Vertical accidental shift must be less than 31!') + call stop1() + end if + ipm = 1 + if (durq .eq. '-') ipm = -1 + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected 2nd number of accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horiz. accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else +c +c Not accid shift, reset, then flow out +c + iccount = icsav + end if + end if + end if + plusmin = .true. + if (numnum .eq. 2) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 +c +c It's a rest containing +|- . Must refer to a vertical shift. Read past. +c + else + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,dum) + iccount = iccount-1 + go to 2 + end if +c else if (index('ulare',durq) .gt. 0) then + else if (index('ularec',durq) .gt. 0) then + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change +c + call g1etchar(lineq,iccount,durq) + if (index('.0123456789:',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a number or colon here!') + call stop1() + end if + if (durq .eq. ':') then + if (.not.stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned off sticky stemshrinks without turning on!') + call stop1() + end if + stickyS = .false. + go to 2 + end if + call readnum(lineq,iccount,durq,dum) + if (dum.lt..5 .or. dum.gt.4.) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Stemlength shortening must be from .5 to 4!') + call stop1() + end if + if (durq .ne. ':') then + iccount = iccount-1 + else + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on sticky stemshrinks when already on!') + call stop1() + end if + stickyS = .true. + end if + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 2 + else if (durq .eq. 'p') then + fulbrp = charq.eq.'r' + if (.not. fulbrp) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'The option "p" only works with "r" (rest)!') + call stop1() + end if + go to 2 + else if (durq .eq. 'b') then + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "b"; I expected "rb"!') + call stop1() + else if (numnum .eq. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "r" & "b" with two numbers!') + end if + go to 2 + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'First char after "x" in xtuplet must be "1"-"9"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (fnum .gt. 99) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Xtuplet cannot have more than 99 notes!') + call stop1() + else if (index(' DFnd',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only legal characters here are " ","D","F","n"!') + call stop1() + end if +c +c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. +c + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here, number already set, but may also +c have used this before number was set. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = 1 + call g1etchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call g1etchar(lineq,iccount,durq) + end if + if (durq .eq. 'n') then +c +c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. +c + numshft = 0 +30 call g1etchar(lineq,iccount,durq) + if (durq .eq. 'f') then + go to 30 + else if (index('+-',durq) .gt. 0) then + numshft = numshft+1 + if (numshft .eq. 3) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only 2 shifts are allowed after "n" in xtup!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit or "."!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if ((numshft.eq.1 .and. snum.gt.15.1) .or. + * (numshft.eq.2 .and. snum.gt.1.51)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Shift number after "n" in xtup is out of range!') + call stop1() + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope alteration for bracket +c + call getchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'For slope adjustment, this character must be "+" or "-"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if (nint(snum) .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slope adjustment cannot exceed 15!') + call stop1() + end if + go to 30 + else if (index('123456789',durq) .gt. 0) then +c +c Unsigned integer => alternate printed number +c + call readnum(lineq,iccount,durq,snum) + if (snum .gt. 15.1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Alternate xtup number after "n" must be <16!') + call stop1() + end if + iccount = iccount-1 + go to 30 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "n" in xtup!') + call stop1() + end if + end if + ntup = nint(fnum) + do 6 itup = 2 , ntup + nodur(ivx,nnl(ivx)) = 0 + nnl(ivx) = nnl(ivx)+1 +110 call g1etchar(lineq,iccount,durq) + if (durq.eq.' ') then + go to 110 + else if (durq .eq. 'o') then +c +c Ornament in xtup. "o" symbol must come AFTER the affected note +c + call g1etchar(lineq,iccount,dumq) + if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then + if (index('fg',dumq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Fermata or segno not allowed in xtuplet!') + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + end if + call stop1() + end if + if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +29 call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') go to 29 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1, + * ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if + go to 110 + else if (index('st(){}',durq) .gt. 0) then +c +c Slur in xtup +c + iposn = 0 + numint = 0 +15 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (index('udlbfnht',dumq) .gt. 0) then + if (dumq.eq.'t' .and. durq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + go to 15 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum).gt.6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in the range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 40 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount, + * ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +40 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 15 + + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 15 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') + * iccount=iccount+1 + go to 15 + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + go to 15 + else if (dumq .ne. ' ') then + ic = ichar(dumq) + if ((ic.ge.48.and.ic.le.57) .or. + * (ic.ge.65.and.ic.le.90)) then + if (iposn .eq. 1) then + if (durq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + go to 15 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be 2nd character in slur symbol!') + call stop1() + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + end if + go to 110 + else if (index('0123456789#-nx_',durq) .gt. 0) then +c +c We have a figure. Only allow on 1st note of xtup +c + if (itup .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Figure in xtup only allowed on 1st note!') + call stop1() + else if (durq.eq.'x') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'No floating figures in xtuplets!') + call stop1() + end if + if (usefig .and. ivx.eq.1) ifig = 1 +26 call g1etchar(lineq,iccount,durq) + if (index('0123456789#-n_.:',durq) .gt. 0) then + go to 26 + else if (durq .eq. 's') then + isligfont = .true. + go to 26 + else if (durq .eq. '+') then +c +c vertical offset, must be integer then blank +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .ne. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 26 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure in xtuplet!') + call stop1() + end if + go to 110 + else if (durq .eq. 'G') then + ngr = 1 +79 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 79 + else if (index('AWulxs',charq) .gt. 0) then + go to 79 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 79 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 79 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 71 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +75 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 75 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +78 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 78 + else if (index('+-nfs',charq) .gt. 0) then + go to 78 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +71 continue + go to 110 + else if (durq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + go to 110 + else if (durq .eq. 'M') then +c +c Temporary trap until I get around putting this in pmxb +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macros not yet allowed in xtuplets!') + call stop1() + else if (durq .eq. 'X') then + call g1etx(lineq,iccount,.false.,shifton, + * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt) + go to 110 + else if (durq .eq. 'z') then +c +c Chord note in xtup. Read past for now. +c +33 call g1etchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 33 + go to 110 + else if (durq .eq. 'D') then +c +c Dynamic mark +c + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + go to 110 + else if (durq .eq. '%') then + if (iccount .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Comment must have "%" in column 1!') + call stop1() + end if + iccount = 128 + go to 110 + else if (durq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + go to 110 + end if + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 110 +c+++ + else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'[' + * .and. lineq(iccount+2:iccount+2).eq.' ') then + iccount = iccount+2 + go to 110 +c+++ + end if +c +c End of xtup options. At this point symbol can only be note or rest +c + if (index('abcdefgr',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In xtup, this character is not allowed!') + call stop1() + else if (durq.eq.'r' .and. itup.eq.ntup) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, PMX cannot end an xtuplet with a rest!') + call stop1() + end if +7 call g1etchar(lineq,iccount,durq) + if (index('2345678ulcb',durq) .gt. 0) then + go to 7 + else if (index('sfn',durq) .gt. 0) then +c +c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 7 + else if (index('+-<>',durq) .gt. 0) then +c +c May have either octave jump or shifted accid. on main xtup note +c + if (index('+-',durq).gt.0 .and. + * index('01234567890',lineq(iccount+1:iccount+1)).eq.0) + * go to 7 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 7 + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = ndoub+1 + go to 7 + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + go to 7 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal option on xtuplet note!') + call stop1() + end if + if (itup .eq. ntup-ndoub) go to 3 +6 continue +3 continue +c +c 6==End of loop for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c + if (mod(itsofar(iv),lenbar) .ne. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest must start at beginning of bar!') + call stop1() + else if (iv.eq.1.and.ibarmbr.gt.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest only OK at one time per block!') + call stop1() + end if +c +c For some purposes, pretend its one bar only +c + nodur(iv,nnl(iv)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 +c20 call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer after "rm"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mbrest = nint(fnum) + iccount = iccount-1 +c if (ichar(durq).ge.48.and.ichar(durq).le.57) then +c mbrest = 10*mbrest+ichar(durq)-48 +c go to 20 +c end if + if (nv .gt. 1) then + if (iv .eq. 1) then + mbrestsav = mbrest + else + if (mbrest .ne. mbrestsav) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must enter same multi-bar rest in every voice!') + call stop1() + end if + end if +c +c Zero out mbrestsav so can check at end of input block whether +c all voices have one +c + if (iv .eq. nv) mbrestsav=0 + end if + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "rm"!') + call stop1() + end if + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. ',') then + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (index('oL',durq) .gt. 0) then +c +c Suppress full bar rest, or look left for height +c + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o","L" options only legal for rest, not note!') + call stop1() + end if + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" or "F" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'A') then +c +c Main note accidental option +c + call getchar(lineq,iccount,durq) + if (index('o+-<>',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o",+","-","<",">" are the only legal options here!') + call stop1() + end if +c +c Need more stuff here +c + if (durq .ne. "o") then +c +c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will +c proceed to number input checking +c + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character!') + print*,'ASCII code:',ichar(durq) + call stop1() + end if +c +c End of block for note options. +c +c Set the duration +c + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) +c +c Check for double dot +c + if (iddot .eq. 1) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + iddot = 0 + end if + else if (fulbrp) then + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + fulbrp = .false. + end if + rest(ivx,nnl(ivx)) = charq.eq.'r' +c +c If inside forced beam, check if note is beamable +c + if (fbon) then + if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120 + if (nnl(ivx) .gt. 1) then + if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unbeamable thing in forced beam!') + call stop1() + end if +120 continue +c +c Get number of prior bars for later check on whether note spans bar line +c + nbb4 = itsofar(ivx)/lenbar + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (mod(itsofar(ivx),lenbar) .eq. 0) then + nbars = nbars+1 + if (shifton) barend = .true. +c +c Will check barend when 1st note of next bar is entered. +c + if (nbars .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot have more than 15 bars in an input block!') + call stop1() + end if + nib(ivx,nbars) = nnl(ivx) + if (firstline .and. lenbar.ne.lenbr1) then +c +c Just finished the pickup bar for this voice. +c + if (itsofar(ivx) .ne. lenbr0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Pickup bar length disagrees with mtrnum0!') + call stop1() + end if + lenbar = lenbr1 + itsofar(ivx) = 0 + end if + else if (barend) then + if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + barend = .false. + else if (itsofar(ivx)/lenbar .gt. nbb4) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'This note spans a bar line!') + call stop1() + end if + if (idotform.eq.1 .or. idotform.eq.3) then + call g1etchar(lineq,iccount,charq) + if (index('abcedfgr',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected note name or "r" here!') + call stop1() + end if + idotform = idotform+1 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then + call g1etchar(lineq,iccount,charq) + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected chord note name here!') + call stop1() + end if +25 call g1etchar(lineq,iccount,durq) +c if (index('dre12345678',durq) .gt. 0) then + if (index('dre12345678c',durq) .gt. 0) then + go to 25 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 25 + else if (durq .eq. 'A') then + if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n" before "A" in chord note!') + call stop1() + end if + go to 25 + else if (index('<>',durq) .gt. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then +c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n,A" before "<" or ">"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here for accidental shift!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (index('+-',durq) .gt. 0) then + if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0) + * go to 25 +c +c Number or '.' (durq) follows +/- . Get it. +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.' .and. index('1234567890', + * lineq(iccount+1:iccount+1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"." here must be followed by a digit!') + call stop1() + else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Number after +/- must follow "d,s,f,n,A"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .eq. 0) then + iccount = iccount-1 + go to 25 + end if +c +c 2nd +/- +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.') call g1etchar(lineq,iccount,durq) + if (index('1234567890',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in chord note!') + call stop1() + end if + else if (charq .eq. 'G') then + ngr = 1 +9 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 9 + else if (index('AWulxs',charq) .gt. 0) then + go to 9 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 9 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 9 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 19 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +55 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 55 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +18 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 18 +c else if (index('nfs',charq) .gt. 0) then + else if (index('+-nfs',charq) .gt. 0) then + go to 18 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +19 continue + else if (charq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. "o" symbol must come AFTER the affected note +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o" must be in same input block, after affected note!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + call stop1() + end if + if (dumq .eq. ':') then + call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after "o:"!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else if (dumq .eq. 'g') then + if (issegno) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, only one "segno" per input block!') + call stop1() + else if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'segno can only be in voice 1!') + call stop1() + end if + issegno = .true. +12 call g1etchar(lineq,iccount,dumq) + if (dumq.eq.'-' .or. + * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12 + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in segno ornament symbol!') + call stop1() + end if + else if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +22 call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after ":"!') + call stop1() + end if + go to 32 + else if (dumq .ne. ' ') then + go to 22 + end if + else if (dumq .eq. 'f') then + call g1etchar(lineq,iccount,dumq) + if (index(' d+-:',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "f" in fermata ornament symbol!') + call stop1() + end if + if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') go to 32 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if +32 continue + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + else if (index('st(){}',charq) .gt. 0) then + numint = 0 + iposn = 0 +8 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (charq.eq.'t' .and. dumq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + if (index('udltb+-fnhHps ',dumq) .eq. 0) then +c +c Check for explicit ID code. +c + ic = ichar(dumq) + if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or. + * ic.gt.90) then +c +c Not 0-9 or A-Z, so exit +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + else +c +c It is a possible ID code. Right place? +c + if (iposn .ne. 1) then +c +c Slur ID is not 2nd! +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be second character in slur symbol!') + call stop1() + else if (charq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + end if +c +c Slur ID is OK. Note it cannot be "H" at this point.. +c + go to 8 + else if (dumq .eq. 'H') then + if (iposn .eq. 1) go to 8 +c +c "H" is NOT an ID code. +c + if (.not.fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + end if + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount=iccount+1 + iposn = iposn+1 + end if + go to 8 + else if (index('fh',dumq).gt.0 .and. .not.fontslur + * .and. charq.eq.'t') then +c +c 3/9/03 Can't reshape postscript tie. +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + iposn = iposn+2 + go to 8 + end if + if (index('udltbfnh',dumq) .gt. 0) then + go to 8 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + if (fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+|-" for slur height only allowed in "s"-slurs!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 41 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +41 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1 + go to 8 + end if + else if (charq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"!') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + end if + else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or. + * index('#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + if (itsofar(ivx).eq.0 .and. + * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then +c +c Figure before first note in block +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot put figure before first note in block!') + call stop1() + end if + if (charq.eq.'x') then + indxb = index(lineq(iccount:128),' ') + if (indxb .lt. 5) then + call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot have a blank here in floating figure!') + call stop1() + end if + end if + if (usefig) ifig = 1 +5 call g1etchar(lineq,iccount,charq) + if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure!') + call stop1() + else if (charq .eq. '+') then +c +c vertical offset, must be integer, then blank +c + call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,charq,fnum) + if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 5 + else if (charq .eq. 's') then + isligfont = .true. + end if + if (charq .ne. ' ') go to 5 + else if (charq .eq. '[') then + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Started forced beam while another was open!') + call stop1() + end if + fbon = .true. +17 call g1etchar(lineq,iccount,charq) + if (index('uljhf:',charq) .gt. 0) then + go to 17 + else if (index('+-',charq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 17 + else if (charq .eq. 'm') then +c +c Forced multiplicity, next char should be 1-4 +c + call g1etchar(lineq,iccount,charq) + if (index('1234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!') + call stop1() + end if + go to 17 + else if (charq .ne. ' ') then + if (index('0123456789',charq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "[", digits must now be preceeded by "+" or "-"!') + print*,'You will have to edit older sources to meet this rqmt,' + print*,'but it was needed to allow 2-digit height adjustments.' + print*,'Sorry for the inconvenience. --The Management' + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after [!') + end if + call stop1() + end if + else if (charq .eq. ']') then + if (.not.fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced beam stop with no corresponding start!') + call stop1() + end if + call g1etchar(lineq,iccount,charq) + if (charq .eq. '-') then + if (lineq(iccount+1:iccount+2) .ne. '[ ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'Only sequence allowed here is "[ "!') + call stop1() + else + iccount = iccount+2 + end if + else if (charq .eq. '[') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else +c +c Forced beam is really ending +c + fbon = .false. + if (charq .eq. 'j') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"]" must be followed by blank, "j", "-", or "["!') + call stop1() + end if + end if + else if (charq .eq. 'D') then +c +c Dynamic mark +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"D" must not come before any notes have been entered!') + call stop1() + end if + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + else if (index('lhw',charq) .gt. 0) then +c +c Save position for later check +c + icclhw = iccount + call g1etchar(lineq,iccount,durq) + if (index('0123456789.+- ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "l", "w", or "h"!') + call stop1() + end if + isheadr = isheadr .or. charq .eq. 'h' + if (index(' +-',durq) .gt. 0) then +c +c There is a header (or lower string?) +c + if (index('+-',durq) .gt. 0) then +c +c User-defined vert offset (\internote). +c + if (charq .ne. 'h') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+" or "-" not permitted here!') + call stop1() + end if +c +c Have "h" followed by +/- . Check for digit. +c Can blow durq since not using fnum for now, but... +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a digit here!') + call stop1() + end if +c +c Have "h" followed by +/- followed by a digit. No need to get the number. +c +c call readnum(lineq,iccount,durq,fnum) + end if + if (charq .ne. 'w') then +c +c Header or lower string. +c + if (icclhw .ne. 1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"h" or "l" must be first character in line!') + call stop1() + end if +c +c Read past the next line, which has the string. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol "w" (width) must be followed by a digit!') + call stop1() + end if + else +c +c Height or width change spec. Check if at start of piece. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol must go at top of first input block!') + call stop1() + end if + call readnum(lineq,iccount,durq,dimen) +c +c Check units. Convert to points +c + if (durq .eq. ' ' .or. durq .eq. 'p') then + dimen = dimen+.5 + else if (durq .eq. 'i') then + dimen = dimen*72+.5 + else if (durq .eq. 'm') then + dimen = dimen/25.4*72+.5 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal unit; must be "p","i",or"m"!') + call stop1() + end if + if (charq .eq. 'h') then + ptheight = int(dimen) + else + widthpt = int(dimen) + end if + end if + else if (charq .eq. 'm') then +c +c Time signature change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Meter change only OK in voice 1, at start of block!') + print*,'voice number is',ivx + call stop1() + end if + newmeter = .true. + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + if (mtrnuml .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Digit 0 not allowed here!') + call stop1() +c else if (mtrdenl .eq. 1) then +cc +cc Kluge!!! +cc +c mtrdenl = 2 +c mtrnuml = 2*mtrnuml + end if + call readmeter(lineq,iccount,mtrnmp,mtrdnp) +c +c Read past printed time signature; not used in pmxa. +c + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnuml*lenbeat + mtrnuml = 0 + else if (charq .eq. 'C') then + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. +c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') + * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!') + call stop1() + end if + gotclef = .true. + else if (charq .eq. 'R') then + if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Repeats can only go in voice 1!') + call stop1() + end if +10 call g1etchar(lineq,iccount,durq) + if (index('lrdDbz',durq) .gt. 0) go to 10 + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "R" (repeat/double bar)!') + call stop1() + end if + else if (charq .eq. 'V') then +c +c Ending +c + if (iv .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Voltas are only allowed in voice #1!') + call stop1() + else if (isvolt) then + print* + print*,'*******WARNING********' + write(15,'(/,a)')'*******WARNING********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There is more than one volta in this input block.!') + print*,'This may work in a score, but WILL NOT work in parts.' + print*, + *'Safest to have only 1 volta per block, at the start of the block' + write(15,'(a)') + * 'This may work in a score, but WILL NOT work in parts.' + write(15,'(a)') + *'Safest to have only 1 volta per block, at the start of the block' + end if + isvolt = .true. + lvoltxt = 0 +11 call g1etchar(lineq,iccount,durq) + if (durq .ne.' ') then + go to 11 + end if + else if (charq .eq. 'B') then + continue + else if (charq .eq. 'P') then + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only allowed at beginning of block!') + call stop1() + end if +16 call g1etchar(lineq,iccount,durq) + if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and. + * ichar(durq).le.57)) go to 16 + if (durq .eq. 'c') then +c +c Expect a centered name, and it has to be last option +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '"') then +c +c Quoted name, go to next quote mark +c + do 35 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. '"') go to 36 +35 continue + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Missing close quote after page number command (P)!') + call stop1() +36 continue + else if (durq .ne. ' ') then +c +c Space-delimited name, look for next blank +c + do 37 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. ' ') go to 38 +37 continue +38 continue + end if + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l","r","c" or digit allowed after "P"!') + call stop1() + end if + else if (charq .eq. 'W') then + call g1etchar(lineq,iccount,durq) + if (index('.0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here!') + call stop1() + end if + call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1)) + else if (charq .eq. 'T') then +c +c Titles +c + call g1etchar(lineq,iccount,durq) + if (index('itc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must put "i", "t", or "c" after "T"!') + call stop1() + end if + ihead = ihead+2**(index('itc',durq)-1) +c +c Maybe a number after 'Tt', but ignore here. Read past string on next line. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else if (charq .eq. 'A') then +27 call g1etchar(lineq,iccount,durq) + if (index('rbsdeK',durq) .gt. 0) then + go to 27 + else if (durq .eq. 'v') then + if (ibarcnt .eq. 0) novshrinktop = .true. + go to 27 + else if (durq .eq. 'a') then + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fbar) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'i') then + call g1etchar(lineq,iccount,durq) +c +c Local interstaff correction. Set to -1. if not specifiec, or after use, +c or anytime except at top, since pmxb handles all times except at top. +c + call readnum(lineq,iccount,durq,tintstf) + if (ibarcnt .eq. 0) fintstf = tintstf + iccount = iccount-1 + go to 27 + else if (durq .eq. 'I') then +c +c Global interstaff correction. Use in place of fintstf if fintstf<0 +c + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'o') then + optimize = .true. + go to 27 + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call g1etchar(lineq,iccount,durq) + if (index('-0st',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "AS", need nv instances of "s,t,-,0"!') + call stop1() + end if + if (durq.eq.'-'.or.durq.eq.'s') then + isize(iiv) = 1 + else if (durq.eq.'t') then + isize(iiv) = 2 + end if +50 continue + go to 27 + else if (durq .eq. 'p') then + fontslur = .false. +42 continue + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,durq) + if (index('shtc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only letters allowed here are "s","h","t","c"!') + call stop1() + end if +c +c Now check for another default modifier +c + go to 42 + else if (index('lh',durq) .gt. 0) then +c +c Flags for optional linebreak ties or header specials +c + go to 42 + else + iccount = iccount-1 + end if + go to 27 + else if (durq .eq. 'N') then +c +c Override default name for a part file. Must have part number, then +c partname in quotes. Must be on line by itself, and start in column 1. +c Will only be passed thru to scor2prt. +c + if (iccount .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must start in column 1!') + call stop1() + end if + ndxquote = index(lineq,'"') + if (ndxquote.lt.4 .or. ndxquote.gt.5 .or. + * index('123456789',lineq(3:3)).eq.0 .or. + * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must be followed by inst. #, then quote!') + call stop1() + end if + ndxquote = index(lineq(ndxquote+1:128),'"') + if (ndxquote .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In "AN", file name must be in quotes!') + call stop1() + end if + iccount = 128 + else if (durq .eq. 'T') then + cstuplet = .true. + else if (durq .eq. 'R') then +c +c Get full name of normal include file; must occupy remainder of line +c + call getpmxmod(.false.,lineq(iccount+1:128)) + iccount = 128 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + if (index('l4',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l" or "4" is allowed here!') + call stop1() + end if + if (durq .eq. 'l' ) then + hoffpt = -25 + voffpt = -45 + else if (durq .eq. '4') then + ptheight = 745 + widthpt = 499 + hoffpt = -24 + voffpt = -24 + end if + go to 27 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "A" must follow one of the letters abcdeiINprRsST!') + call stop1() + end if + else if (charq .eq. 'K') then +c +c Rules and function of K command +c +c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is +c initial sig, and must be passed to pmxb because it is needed when topfile +c is called, which is before the K+n+m command is read in pmxb. Also, we +c compute and save ibrkch and newkey for each syst, accounting for key changes, +c then adjust fbar to make poenom much more accurate. +c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. +c + call g1etchar(lineq,iccount,durq) + if (index('+-i',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"K" (transpose or key change) must be followed by "+,-,i"!') + call stop1() + end if + if (durq .ne. 'i') then +c +c Normal key change and/or transposition) +c +c iccount = iccount+1 + num1 = 44-ichar(durq) +c +c num1= +1 or -1 +c + ztrans = num1.eq.-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st +/- must be followed by a number!') + call stop1() + end if +c iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = nint(fnum)*num1 + ztrans = ztrans .and. num1.eq.0 + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st number after "K" must be followed by "+,-"!') + call stop1() + end if + iccount = iccount+1 + num2 = 44-ichar(durq) + call readnum(lineq,iccount,durq,fnum) + num2 = num2*int(fnum+.1) + if (num1.eq.0 .and. .not.ztrans) then +c +c Key change, only one per block allowed +c + if (iskchb) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one key change allowed per input block!') + call stop1() + end if + iskchb = .true. + nkeys = nkeys+1 + kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0 +c +c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. +c + ibrkch(nkeys) = ibarcnt+nbars + if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1 + newkey(nkeys) = num2+idsig + else +c +c Transposition +c + fulltrans = .true. + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Transposition must be at top of first input block!') + call stop1() + end if + isig1 = num2 + idsig = isig1-newkey(1) +c +c idsig is the difference between sig after transposition, and sig in setup. +c It may alter # of accid's in key changes if there is transposition. +c + end if + else ! durq='i' +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; +c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c if (fulltrans) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot yet combine full and instrument transposition!') +c call stop1() +c end if + call GetiTransInfo(.true.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '|') then +c +c Optional bar symbol +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar line marker out of place!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + else if (charq .eq. '/') then + if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with repeated ornament still on!') + ornrpt = .false. + end if + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with sticky stemshrink still on!') + stickyS = .false. + end if + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block ended with forced beam open!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + else if (gotclef) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not enter clef at end of input block!') + call stop1() + end if + barend = .false. +c +c Perform time checks +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not divisible by lenbar!') + print*,'lenbar is ',lenbar + call stop1() + else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then + print* + print*,'# of bars in voice 1, current voice:', + * itsofar(1)/lenbar,itsofar(ivx)/lenbar + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not equal to voice 1!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new voice +c + if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0 + nbars = 0 + if (durq .eq. ' ') then +c +c New voice is on next staff +c + iv = iv+1 + ivx = iv + else +c +c New voice is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + if (ivx .gt. nm) then + write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm, + * ' lines of music at once' + call stop1() + end if + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + do 24 j = 1 , 200 + rest(ivx,j) = .false. + nacc(ivx,j) = 0 +24 continue +c +c For midi stuff, record that there is a 2nd line of music in this voice +c + if (ismidi) twoline(iv) = .true. + end if + end if + iccount = 128 + else if (charq .eq. 'S') then +c +c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"S" can only be in first input block!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit must follow "S"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + nsyst = nint(fnsyst) +14 continue + if (durq .eq. 'P') then +c +c New npages for parts. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + npages = nint(fnsyst) + go to 14 + else if (durq .eq. 'm') then +c +c Reset musize (musicsize). +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + musize = nint(fnsyst) + wheadpt = whead20*musize + go to 14 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in "S" symbol!') + call stop1() + end if + else if (charq .eq. 'L') then + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+nbars+1 + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced line break!') + call stop1() + end if + call readnum(lineq,iccount,durq,sysflb) + isysflb(nflb) = nint(sysflb) + if (nflb .gt. 1) then +c +c Check if new number is > prior one +c + if (isysflb(nflb) .le. isysflb(nflb-1)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You already forced a line break at a later line!') + call stop1() + end if + end if + if (npages .eq. 0) then + print* + print*,'WARNING! You forced a line break at line ', + * isysflb(nflb),' but npage = 0. Continue?' + read(*,'(a)') charq + if (index('yY',charq) .eq. 0) call stop1() + else if (isysflb(nflb) .gt. nsyst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced line break at line num > nsyst!') + call stop1() + else if (index(' PM',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have " ", "P", or "M" here!') + call stop1() + end if + if (durq .eq. 'P') then +c +c Forced page break here, get page number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced page break!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + nfpb = nfpb+1 + ipagfpb(nfpb) = nint(fnum) + isysfpb(nfpb) = isysflb(nflb) + if (ipagfpb(nfpb) .gt. npages) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break at page num > npages!') + call stop1() + else if (nfpb .gt. 1) then + if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break numbers must increase!') + call stop1() + end if + end if + end if + if (index(' M',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in linebreak symbol!') + call stop1() + else if (durq .eq. 'M') then + nmovbrk = nmovbrk+1 + isysmb(nmovbrk) = isysflb(nflb) + call g1etchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Vertical spacing, read past number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer required here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + go to 31 + else if (durq .eq. 'i') then +c +c Change indentation, +c + call g1etchar(lineq,iccount,durq) + if (index('.123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Decimal number required here!') + call stop1() + end if +c +c fracsys was initialized in block data to all 0.'s +c + call readnum(lineq,iccount,durq,fracsys(nmovbrk)) + go to 31 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have "+" or "-" after "r" as movement break option!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iorig in original list of instruments. +c + nv = 0 + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number, get next two characters +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')ninow + else +c +c durq is a single digit number for noinow +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq// + * ' at movement break!') + call stop1() + end if + ninow = ichar(durq)-48 + end if + if (ninow.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New number of instruments must be <= original!') + call stop1() + end if + do 63 iinow = 1 , ninow + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal 2-digit instrument number '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')iorig + else +c +c durq is a single digit number for iorig +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal instrument number '//durq// + * ' at movement break!') + call stop1() + end if + iorig = ichar(durq)-48 + end if + if (iorig .gt. noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New instrument number must be <= original noinst!') + call stop1() + end if + nv = nv+nsperi(iorig) +63 continue + do 61 iiv = 1 , nv +c +c Get clef names +c + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!') + call stop1() + end if +c +c Initialize new voices +c + nvmx(iiv) = 1 + ivmx(iiv,1) = iiv + itsofar(iiv) = 0 + nnl(iiv) = 0 + do 62 j = 1 , 200 + rest(iiv,j) = .false. +62 continue +61 continue +c +c Loop back up, this might not be last option in M +c + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after Movement break symbol!') + call stop1() + end if + if (fracsys(nmovbrk) .lt. 0.001) then +c +c Since fracsys was not explicitly set, set it to prior value. +c + if (nmovbrk .eq. 1) then + fracsys(nmovbrk) = fracindent + else + fracsys(nmovbrk) = fracsys(nmovbrk-1) + end if + end if + end if +c +c Just before exiting if-block for forced line breaks, set counter to use when +c dealing with vertical space calcs +c + nistaff(nflb) = nv-1 + else if (charq .eq. 'F') then + usefig = .false. + else if (charq .eq. 'X') then + call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1, + * udsp(ibarcnt+nbars+1),wheadpt) + else if (charq .eq. 'I') then +c +c MIDI settings. +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MIDI stuff only allowed at start of block!') + call stop1() + end if + if (nv .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry but MIDI does not work with more than 15 voices!') + call stop1() + end if + ismidi = .true. + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.true.) + else if (charq .eq. 'M') then + call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx, + * nline) + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + else + print*,'ASCII code:',ichar(charq) + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character is not allowed here!') + print*,'ASCII code:',ichar(charq) + call stop1() + end if + return + end + subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey,npages,nsyst,musize,bottreb) + parameter(nm=24,maxblks=4000) + character*65536 bufq + character*1 chax + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*128 lineq + logical lastchar,issegno,isheadr,isvolt,fbon,bottreb, + * newway + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 +c +c Get the first line +c + iccount = 0 + nline = 1 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') then + nline = nline+1 + go to 9 + end if + if (lineq(1:3) .eq. '---') then +c +c Have TeX input until next line that starts with '---' +c +3 nline = nline+1 + call getbuf(lineq) + if (ilbuf .gt. nlbuf) go to 1 + go to 2 +1 print*,'You did not terminate type 0 TeX input with "---"' + call stop1() +2 continue + if (lineq(1:3) .ne. '---') go to 3 +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq and nline are first non-TeX lines. +c + nv = nint(readin(lineq,iccount,nline)) + if (nv .gt. nm) then + write(*,'(1x,a46,i3)') + * 'In setup data, number of voices cannot exceed',nm + call stop1() + end if + noinst = nint(readin(lineq,iccount,nline)) + if (noinst .gt. nv) then + write(*,'(a)') + * 'In setup data, cannot have more instruments than staves' + call stop1() + end if + newway = noinst.le.0 + if (newway) noinst = -noinst + do 10 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if +10 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge!!! +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then + write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8' + call stop1() + end if + xmtrnum0 = readin(lineq,iccount,nline) + newkey = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) + if (fracindent .ge. 1.) then + write(*,'(a)')'In setup data, fracindent must be <1' + call stop1() + end if + if (npages .gt. nsyst) then + print*,'Error in input file: npages > nsyst' + call stop1() + else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then + call printl('Musicsize must be 16, 20, 24, or 29') + call stop1() + end if +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , abs(noinst) +5 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 6 + do 7 iv = 1 , nv +c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then + if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then + call errmsg(lineq,iv,0, + * 'There should be a clef symbol here!') + call stop1() + end if +7 continue + if (lineq(nv+1:nv+1) .ne. ' ') then + call errmsg(lineq,nv+1,0, + * 'There should be a blank here!') + call stop1() + end if +c +c Set flag if voice 1 is treble, since it affects vertical spacing +c + bottreb = lineq(1:1).eq.'t' +c +c Mext non-comment line has path name +c +8 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 8 + lpath = index(lineq,' ')-1 + if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then + call errmsg(lineq,lpath,0, + * 'Last character of pathname is not "/",":", or "' + * //chax(92)//'"!') + call stop1() + end if + return + end + subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c + logical notxtup,shifton,number,btest + character*128 lineq + character*1 charq,dumq + number = .false. + nPBSc = 0 +1 call g1etchar(lineq,iccount,charq) + if (index('PBS:',charq) .gt. 0) then +c +c Continue checking here even if "P". +c + ipbsc = index('PBS:',charq) + if (btest(nPBSc,ipbsc)) then + call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!') + call stop1() +c else if (.not.notxtup .and. ipbsc.gt.2) then +c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') +c call stop1() + end if + nPBSc = ibset(nPBSc,ipbsc) + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (index('+-',charq) .gt. 0) then + call g1etchar(lineq,iccount,dumq) + if (index('.0123456789',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibar,'Expected a number here!') + call stop1() + end if + end if + call readnum(lineq,iccount,dumq,fnum) + if (charq.eq.'-') fnum = -fnum + if (dumq .ne. 'p') then + iccount = iccount-1 + fnum = fnum*wheadpt + end if + go to 1 + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!') + call stop1() + end if +c +c Done with parsing. Other checks +c + if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then + call errmsg(lineq,iccount-1,ibar, + * 'Cannot have both "P" and "B" or "S" and ":"!') + call stop1() + end if + if (btest(nPBSc,4)) then + if (number) then + if (shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Started a group shift without stopping prior one!') + call stop1() + else + shifton = .true. + end if + else + if (.not. shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Ended a group shift without starting one!') + call stop1() + else + shifton = .false. + end if + end if + end if +c +c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) +c + if (iand(nPBSc,26).eq.0) udsp = udsp+fnum + if (.not.number .and. .not.btest(nPBSc,4)) then + call errmsg(lineq,iccount-1,ibar, + * 'Must have either a number or a colon in "X" symbol!') + call stop1() + end if + return + end +c integer*4 function mytime() +c CHARACTER(10) tq +c CALL DATE_AND_TIME(TIME=tq) +c read(tq,'(2i2,f6.3)')ih,im,ts +c mytime = 1000*(ts+60*(im+60*ih)) +c return +c end + subroutine getbuf(lineq) + parameter (maxblks=4000) + character*(*) lineq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) + ipbuf = ipbuf+lbuf(ilbuf) + ilbuf = ilbuf+1 + return + end + subroutine getchar(lineq,iccount,charq) + parameter (nm=24) +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,equalize,stickyS + character*1 charq,rptfq1,rptfq2 + character*128 lineq,lnholdq + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not. endmac) then + iccount = 0 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call mrec1(lineq,iccount,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return +999 continue + lastchar = .true. + return + end + subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount) + parameter (nm=24) + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 durq,chax + character*4 dynsymq + character*128 lineq +c +c Get info for dynamic mark. Enter after getting "D", iccount sits on "D" +c Bits in idyndat are as follows +c 00-03 ivx +c 04-11 ip +c 12-15 code for type of mark +c 0 => arbitrary text +c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff +c If (.not. fontslur) +c 13 => hairpin start, 14,15 => <,> (ending) +c else +c 13 < start, 14 > start, 15 ending +c end if +c 16 flag for vertical offset +c 17-23 vertical offset + 64 , \internote +c 31 Hairpin start (0), stop (1) +c +c idynda2 +c +c 00 flag for horizontal offset +c 01-09 (horizontal offset)/10 + 25.6 notehead widths +c 10 5th bit for ivx (5/15/10) +c + irest = ibset(irest,26) + ndyn = ndyn+1 + idyn = ivx + idynda2(ndyn) = 0 + if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1) + call setbits(idyn,8,4,ip) + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c text-dynamic +c + ntxtdyn = ntxtdyn+1 + iend = iccount+index(lineq(iccount+2:128),'"')+2 + txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) +c +cc Store ivx, ip in bits 0-11 +c Store ivx, ip in bits 0-12 +c +c ivxiptxt(ntxtdyn) = idyn + ivxiptxt(ntxtdyn) = ivx+32*ip + ipm = index('- +',lineq(iend:iend)) + idno = 0 + else +c +c Word-group or hairpin +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) +c +c Exit the loop at first blank, "+", or "-" +c + if (ipm .gt. 0) go to 2 +1 continue +2 continue + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ', + * dynsymq)+3)/4 +c +c Save for later down +c + idno1 = idno + end if +c +c Set flag to check level later if in beam +c + iornq = ibset(iornq,23) + if (idno.ge.14) then +c +c Hairpin here. Check if opposite type from one that's already on +c + if (idno.eq.14.and.btest(listdecresc,ivx) .or. + * idno.eq.15.and.btest(listcresc,ivx)) then + call printl(' ') + call printl('Started one kind of hairpin while other is on') + call stop1() + end if +c +c Start or stop? +c + if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then +c +c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. +c + if (.not.fontslur) idno = 15 + else if (fontslur) then +c +c Start of font slur +c + idno = 13 + else +c +c Start of postscript slur +c + idno = idno-1 + end if + end if +c +c Now that we used list[de]cresc, update +c + if (idno .ge.13) then + if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then +c +c Something's ending +c + if (btest(listcresc,ivx)) then +c +c It's a cresc! +c + listcresc = ibclr(listcresc,ivx) + else + listdecresc = ibclr(listdecresc,ivx) + end if + else +c +c Something's starting +c + if (idno1 .eq. 14) then +c +c It's a cresc! +c + listcresc = ibset(listcresc,ivx) + else + listdecresc = ibset(listdecresc,ivx) + end if + end if + end if + call setbits(idyn,4,12,idno) + iccount = iend + if (ipm .ne. 2) then +c +c There is a vertical shift +c + idyn = ibset(idyn,16) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + call setbits(idyn,7,17,(ipm-2)*idno+64) + ipm = index('- +',durq) + if (ipm .ne. 2) then +c +c There is a horizontal shift +c +c idynda2(ndyn) = ibset(idyn,23) + idynda2(ndyn) = ibset(idynda2(ndyn),0) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256) + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + idyndat(ndyn) = idyn + return + end + subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig, + * itsofar,nodur,figq,ivupfig,nfigs) + logical isfig + character*1 charq + character*10 figq + character*128 lineq +c +c As of 11/26/08, trapped extra figures in getnote, so no need here. +c +c if (ivx .gt. 2) then +cc +cc Read past the figure +cc +c6 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') go to 6 +c return +c end if + nfigs = nfigs+1 + ivupfig = 0 + itoff = 0 + if (charq .eq. 'x') then +c +c Floating figure. +c + call getchar(lineq,iccount,charq) + read(charq,'(i1)')noff + call getchar(lineq,iccount,charq) + read(charq,'(i1)')loff + itoff = noff*ifnodur(loff,'x') + call getchar(lineq,iccount,charq) + else +c +c Figure on a note +c + isfig = .true. + end if + itfig = itsofar+itoff-nodur + lfig = 1 + figq = charq +5 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') then + if (index(' +',charq) .eq. 0) then + figq = figq(1:lfig)//charq + lfig = lfig+1 + go to 5 + else if (charq .eq. '+') then +c +c Get vertical offset for figure. Next character after number has to be blank. +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ivupfig = nint(fnum) + end if + return + end + subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + parameter (nm=24) + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg + character*1 charq,durq + character*20 voltxtq + character*128 lineq,litq + integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm), + * ndlev(nm,2) + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c + 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,iTransAmt(instno(iv))) + 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,iTransAmt(instno(iv)))-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 + return + end + subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) +cccccccccccccccccccccccc +cc +cc GetiTransInfo.for +cc +cccccccccccccccccccccccc +c +c Called from both g1etnote and getnote, after first 'i' in Ki[...] +c On entry, iccount points to last char retrieved, which is 'i' +c +c From1: locgical, true if called from g1etnote +c ibarcnt: tells whether to set EarlyTransOn to true. +c EarlyTransOn set false in blkdata, true here, back to false in topfile. +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; +c LaterInstTrans from getnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c iTransAmt stored as fn of instrument #, not like iTransKey which is +c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This +c simplifies use of iTransAmt for all calls to ifnolev. +c + parameter (nm=24) + logical From1 + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans,store + character*128 lineq + character*1 durq + durq = 'x' ! Can't initialize in declaration stmt, only works once. + if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0 + store = (EarlyTransOn.and.ibarcnt.eq.0) .or. + * (ibarcnt.gt.0.and..not.From1) + LaterInstTrans = .not.From1 .and. ibarcnt.gt.0 + if (store) nInstTrans = 0 +1 continue + if (durq .eq. ' ') return + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be an instrument number here!') + call stop1() + end if + if (store) nInstTrans = nInstTrans+1 + call readnum(lineq,iccount,durq,fnum) + instn = nint(fnum) + if (instn.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Instrument number out of range!') + call stop1() + end if + if (store) iInstTrans(nInstTrans) = instn +c +c durq is +/- following inst # (for iTransAmt), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after instrument number must be "+,-"!') + call stop1() + end if + itramt = 44-ichar(durq) ! +1/-1 for itramt + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a transposition amount here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransAmt(instn) = nint(fnum)*itramt +c +c durq is +/- following iTransAmt (for iTransKey), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after transposition amount must be "+,-"!') + call stop1() + end if + ikey = 44-ichar(durq) ! +1/-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a key indicator here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransKey(nInstTrans) = nint(fnum)*ikey +c +c durq is now 1st character after iTransKey, should be either 'i' or ' ' +c + if (durq.ne.'i'.and.durq.ne.' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be blank or "i" here!') + call stop1() + end if + go to 1 + end + subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,first) +c +c Use this from both pmxa and pmxb to input and check midi data. "first" tells +c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause +c things to be written immediately into the midi storage buffers. +c + parameter (nm=24,mv=24576) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c + integer*2 mmidi,midinum(26) + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + character*1 durq + character*2 instq + character*128 lineq + logical first + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Instrument codes +c + data midinum + * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67, +c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX +c + * 68,69,71,72,74,75, 8,55 / +c bsXobXbaXclXflXreXctXvo +c +1 call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Tempo in beats ber minute +c + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the pause!') + call stop1() +c else if (mmacrec) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot change MIDI tempo while recording a MidiMacro!') +c call stop1() + end if + call readnum(lineq,iccount,durq,qpm) + iccount = iccount-1 + if (.not.first) then + call midievent('t',nint(qpm),0) + gottempo = .true. + end if + go to 1 + else if (durq .eq. 'p') then +c +c Insert a pause. pausemid = pause in 1/4's +c + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here for the pause!') + call stop1() + end if + call readnum(lineq,iccount,durq,pausemid) + iccount = iccount-1 + if (.not.first) then +c +c Compute a meter for the pause. This is only to keep MidiNotate on track. +c Round pause to nearest 16th. Let denominator always be 16. +c + numb16 = nint(pausemid*4) + call midievent('m',numb16,16) +c +c Put in pausemid beats of rest +c + do 3 icm = 0 , numchan-1 + call addmidi(icm,0,0,0,4.*numb16,.true.,.false.) +3 continue + miditime = miditime+nint(240*pausemid) +c +c Restore meter +c + call midievent('m',mtrdenl*lenbar/64,mtrdenl) + end if + go to 1 + else if (durq .eq. 'i') then +c +c Instrument numbers or letters. Expect nv of them. +c + do 2 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (ichar(durq) .gt. 96) then +c +c It's a lowercase letter. Get another, find corr. instrument #. +c + instq(1:1) = durq + call getchar(lineq,iccount,durq) + instq = instq(1:1)//durq + iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'// + * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3 + if (iname .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unrecognized 2-letter midi instrument name!') + call stop1() + end if + midinst(ivx) = midinum(iname)-1 + else +c +c Expect a number, followed by ":" if that is followed by another number. +c I.e., if after call to readnum, durq is not ":", it must be either blank +c or next instrument letter. +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi instrument number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midinst(ivx) = nint(fnum)-1 + if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi instrument number must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 + end if +2 continue + go to 1 + else if (durq .eq. 'v') then +c +c Get volumes for each instrument. Expect nv of them. +c Follow same pattern as for insttrument numbers above. +c + do 7 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi velocity number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midivel(ivx) = nint(fnum)-1 + if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi velocity must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +7 continue + go to 1 + else if (durq .eq. 'b') then +c +c Get balance for each instrument. Expect nv of them. +c Follow same pattern as for instrument numbers above. +c + do 8 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a balance number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midibal(ivx) = nint(fnum)-1 + if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi balance must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +8 continue + go to 1 + else if (durq .eq. 'T') then +c +c Get transposition for each instrument. Expect nv of them. +c Follow similar pattern as above, but separator is +|-. +c + do 9 ivx = 1 , nv + call getchar(lineq,iccount,durq) + ipm = index('-+',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" for midi transposition here!') + call stop1() + end if + ipm = 2*ipm-3 + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + miditran(ivx) = ipm*nint(fnum) +c if (mod(miditran(ivx),12).ne. 0) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Midi transposition limited to multiples of 12!') +c call stop1() +c end if + iccount = iccount-1 +9 continue + go to 1 + else if (durq .eq. 'g') then + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the midi gap!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mgap = nint(fnum) + iccount = iccount-1 + go to 1 + else if (durq .eq. 'M') then +c +c MidiMacros +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'R') then +c +c Start recording +c + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to record a MidiMacro while already recording!') + call stop1() + end if + mmacrec = .true. + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (immac .gt. 20) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MidiMacro ID cannot exceed 20!') + call stop1() + end if +c +c Save the start time +c + mmactime(immac) = miditime + do 4 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then +c +c Adjust if there's a rest at end of prior section. Insert dummy turnoff. +c (This causes two turn-offs in a row, which testmidi sees as an error). +c +c Before: section1 ------rest------- section2(to be recorded) +c After: section1 rest1 now rest2 section2(recorded) +c + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacstrt(icm,immac) = imidi(icm)+1 +4 continue + end if + go to 1 + else if (index('123456789P',durq) .eq. 0) then +c +c End recording; close the open macro. Get immac from common. +c + if (.not.mmacrec) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You tried to end a MidiMacro before starting one!') + call stop1() + end if + mmacrec = .false. + iccount = iccount-1 + if (.not.first) then +c +c Save the macro duration +c + mmactime(immac) = miditime-mmactime(immac) + do 5 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track if needed. +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacend(icm,immac) = imidi(icm) +5 continue + end if + if (durq .ne. ' ')go to 1 + else if (durq .eq. 'P') then +c +c Play Back a Macro +c + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to play a MidiMacro before ending recording!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (mmactime(immac) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a MIDI macro before recording it!') + call stop1() + end if + do 6 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0. + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + end if + end if + msecend(icm,nmidsec) = imidi(icm) + msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac) + msecend(icm,nmidsec+1) = mmacend(icm,immac) + msecstrt(icm,nmidsec+2) = imidi(icm)+1 +6 continue + nmidsec = nmidsec+2 +c +c Update running time +c + miditime = miditime+mmactime(immac) + lasttime = miditime + end if + go to 1 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MidiMacro sub-command!') + call stop1() + end if + else if (durq .eq. 'd') then + debugmidi = .true. + go to 1 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MIDI input data!') + call stop1() + end if + if (.not.gottempo .and. .not.first) then +c +c If no tempo is set on first call on the pmxb pass, then set it +c + call midievent('t',96,0) + gottempo = .true. + end if + return + end + subroutine getnote(loop) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*10 figq + character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax + logical beamon,firstgulp,figbass,figchk,isfig + character*60 cheadq + character*120 instrq,titleq,compoq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp, + * was2,nobar1,quoted,isbj2,stickyS, + * OptLineBreakTies,HeaderSpecial + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /combc/ bcspec + common /comas3/ ask(2500),iask,topmods +c +c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined +c ivx is current ivmx, and is the index for all notes, acc's etc. +c + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comtrans/ cheadq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + common /comclefq/ clefq(nm) + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + character*128 txtdynq + logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur, + * fontslur,WrotePsslurDefaults + character*128 lineq,lnholdq + character*80 headrq, lowerq + character*79 inameq + character*59 hdlndq + character*20 voltxtq + character*1 charq,dotq,durq,ulfbq,dumq + logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved, + * topmods,headlog,btest,sluron,cdot,equalize + character*24 tempq + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1, + * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3 + logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3 + common /combibarcnt/ ibarcnt + cdot = .false. +1 call getchar(lineq,iccount,charq) + if (lastchar) return + if (charq .eq. ' ') go to 1 + if (charq .eq. '%') then +c +c Check for a bar number format: +c + if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and. + * index('bB1234567890',lineq(3:3)).gt.0) then + if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128)) + end if + iccount = 128 + go to 1 + end if +c +c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' +c + if (rptprev) then + rptnd1 = charq .eq. '/' + rptprev = .false. + end if +c +c Repeat at end of a piece +c + if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + * charq.eq.'r') then + if (cdot) go to 28 +c +c This is a note/rest. +c + idotform = 0 + numnum = 0 +c +c If start of line of music, set pitch from previous +c + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv) +c +c notcrd is used to tell if orn. goes on main note or chord note +c +c notcrd = .true. !Move dow. Was not observed if dotted shortcut. +c +c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. +c +28 continue +c +c Moved this from just above, 2 Feb 02 +c + notcrd = .true. + nnl(ivx) = nnl(ivx)+1 + if (ornrpt) then +c +c Replicate ornament bits, also bit 23 for beam handling if chord. +c + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + if (stickyS) then +c +c Grab stemlength shortening parameters from prior note +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + end if + if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then +c +c Doing auto forced beams, and period has been set, so check if this note +c starts a period. +c +c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Start a forced beam here +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + end if + end if + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) + dotq = 'x' + if (charq.eq.'r') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (btest(irest(ivx,nnl(ivx)),0)) then +c +c Rest stuff. First check if previous note was full-bar-pause +c + if (lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1) then + if (btest(islur(ivx,nnl(ivx)-1),19)) + * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + end if +c +c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 +c for voice a or b. Set a-types at 0 as encountered and adjust later +c after '//'. (Override heights will be set to 100+offset) +c + if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if +2 call getchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + ioct = ic-48 + numnum = 2 + go to 2 + else + print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx) + call stop1() + end if + else if (durq .eq. 'd') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then +c +c Double dot. +c + iccount = iccount+1 + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3) + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0) + * go to 2 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19) + call getchar(lineq,iccount,durq) + ndotmv(ivx) = ndotmv(ivx)+1 + iccount=iccount+1 + call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx))) + if (durq .eq. '-') + * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx)) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx))) + if (dumq .eq. '-') + * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx)) + else + rtdot(ivx,ndotmv(ivx)) = 0. + end if + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. 'p') then +c +c Full-bar rest as pause +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'b') then +c +c Blank rest +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Accidental +c + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accidental has been set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Repeated accid, so must be double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + go to 2 + else if (durq .eq. 'i') then +c +c Set flag for MIDI-only accidental. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + go to 2 + else if (index('+-<>',durq) .gt. 0) then + ipm = index('- +',durq)-2 + if (.not.btest(irest(ivx,nnl(ivx)),0)) then +c +c A note, not a rest. +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (moved) go to 2 +c +c Octave jump with a note +c + if (numnum .lt. 2) then + lastlev = lastlev+ipm*7 + else + ioct = ioct+ipm*1 + end if + go to 2 + else +c +c Override default height of a rest +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (lineq(iccount-1:iccount-1) .eq. '.') then +c +c Kluge in case there is a shortcut ".". It will have been sucked up by +c readnum. (Same doesn't hold for ",") +c + iccount = iccount-2 + go to 2 + end if + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) +c +c There may be more characters for this rest +c + iccount = iccount-1 + go to 2 + end if + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. Set flag on this note. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28) +c +c Next input will be digit +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ntup = nint(fnum) + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here xtup number already set but may also +c have this command before. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = 1 + call getchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + end if +c +c Only other possibilities here are ' ' or 'n' +c + if (durq .eq. 'n') then +c +c Alter xtup number +c + if (lineq(iccount+1:iccount+1) .eq. ' ') then +c +c If the only modifier is 'n', cancel the number +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) + else + numshft = 0 +30 call getchar(lineq,iccount,durq) + if (durq .eq. 'f') then +c +c Flip up-down-ness +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14) + go to 30 + else if (index('+-',durq) .gt. 0) then +c +c Vertical or horiz shift +c + numshft = numshft+1 + iofforn = 1 + if (durq .eq. '-') iofforn = -1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + if (numshft .eq. 1) then +c +c Vertical shift +c + iofforn = iofforn*nint(xofforn) + 16 +c +c Turn on bit 1; set bits 2-6 to iofforn +c + irest(ivx,nnl(ivx)) = + * ior(irest(ivx,nnl(ivx)),2+4*iofforn) + else +c +c Horizontal shift +c + iofforn = iofforn*nint(xofforn*10)+16 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7) + call setbits(irest(ivx,nnl(ivx)),5,9,iofforn) + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope adjustment for bracket +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4) + call getchar(lineq,iccount,durq) + iofforn = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + iofforn = nint(iofforn*xofforn+16) + call setbits(mult(ivx,nnl(ivx)),5,5,iofforn) + else if (index('123456789',durq) .gt. 0) then +c +c Replacement printed number +c + call readnum(lineq,iccount,durq,xofforn) + call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn)) + iccount = iccount-1 + go to 30 + end if + end if + end if +c +c Set note level of 1st note of xtup, provided not a rest +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + end if + do 40 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on starting note of xtuplet +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +40 continue + numnum = 0 + nodur(ivx,nnl(ivx)) = 0 + do 6 itup = 2 , ntup + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + nnl(ivx) = nnl(ivx)+1 + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) +7 call getchar(lineq,iccount,charq) + if (charq .eq. ' ') then + go to 7 + else if (charq .eq. '%') then + iccount = 128 + go to 7 + else if (charq .eq. 'o') then +c +c Ornament in xtuplet. "o" symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)-1) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1), + * iornq(ivx,0),ornrpt,noffseg, + * nnl(ivx)-1,ivx,.false.,notcrd,nole) + go to 7 + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx)-1 + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detected preslur in xtuplet loop, non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') islur(ivx,nnlivx) = + * ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + go to 7 + else if (charq .eq. 'G') then +c +c Kluge to get grace in xtup at right location +c + nnl(ivx) = nnl(ivx)-1 + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + nnl(ivx) = nnl(ivx)+1 + go to 7 + else if (charq .eq. sq) then + call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount) + go to 7 + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c Figure. Must come AFTER the first note of xtup +c + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx), + * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) + go to 7 + else if (charq .eq. 'X') then + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)), + * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx, + * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur, + * dotq,ndoub) + go to 7 + else if (charq .eq. 'z') then +c +c Chord note in xtup. Goes with *prior* note. +c + notcrd = .false. + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx)-1 + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +34 call getchar(lineq,iccount,durq) +c +c When chord note is done, will get ' ', making ndx=0, so go past this block +c + ndx = index('fsn+-<>12345678reic',durq) + if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 19) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)-1) = + * ibset(iornq(ivx,nnl(ivx)-1),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14, + * igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20, + * igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)-1) = + * ibset(irest(ivx,nnl(ivx)-1),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else +c +c must be a number, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 34 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 41 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on chord note in xtup +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Following lines copied from loop for non-xtup, chord note, preslur +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0) + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0) + isdat2(nsdat-npreslur+1) = + * ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +41 continue + go to 7 + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)-1),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx)-1 + ArpShift(NumArpShift) = fnum + end if + go to 7 + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1), + * iornq(ivx,nnl(ivx)-1),lineq,iccount) + go to 7 +c+++ + else if (charq .eq. ']') then +c +c Multiplicity up-down, must have '][ ' +c + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20) + iccount = iccount+2 + go to 7 +cc+++ + end if +c +c End of loop for xtup options. If here, charq must be a (non-crd) note name. +c or rest +c + if (charq .eq. 'r') then +c +c Rest in xtup +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then + call getchar(lineq,iccount,durq) + if (durq .eq. 'b') then +c +c Blank rest in middle of xtup +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + else +c +c Override height of embedded xtup rest +c + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) + iccount = iccount-1 + end if + else if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if + notcrd = .true. +8 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then + if (index('+-<>',durq) .gt. 0) then +c +c Accidental horizontal shift +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (.not.moved) then + if (durq.eq.'+') then + lastlev = lastlev+7 + else if (durq.eq.'-') then + lastlev = lastlev-7 + end if + end if + else if (index('fsn',durq) .gt. 0) then + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accid set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Symbol must be repeated, so it's a double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + else if (durq .eq. 'i') then +c +c Set flag for midi-only accidental +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (index('ul',durq) .gt. 0) then +c +c Force stem direction for non-beamed xtup note +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + else if (durq .eq. 'e') then +c +c Left-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then +c +c Right-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = ndoub+1 + else if (durq .eq. 'd') then +c +c Dotted xtup note +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + else +c +c Must be an octave number +c + lastlev = ifnolev(charq,ichar(durq)-48 + * ,iTransAmt(instno(iv))) + end if + go to 8 + end if + if (itup .lt. ntup) then +c +c Last note is handled *after* flowing out of the xtup if block, but still +c within block for a note-rest. Set note level now (rest already done). +c Could have problem here if rests & doubled notes are combined in xtup, +c since might exit the loop at the wrong place. Worry about it later. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + lastlev = lastlev-3+mod(ifnolev(charq,10, + * iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + nodur(ivx,nnl(ivx)) = 0 + do 42 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on internal xtup note +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +42 continue + end if + if (itup .eq. ntup-ndoub) go to 12 +6 continue +12 continue + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if +c +c End of if-block for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c For some purposes, pretend its one bar only +c + nodur(ivx,nnl(ivx)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 + xb4mbr = 0. +20 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48.and.ichar(durq).le.57) then + mbrest = 10*mbrest+ichar(durq)-48 + go to 20 + end if + else if (index('ul',durq) .gt. 0) then +c +c Set stem flipper +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'a') then +c +c "Alone", i.e., prohibit beam +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'r') then +c +c Right offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + go to 2 + else if (durq .eq. 'e') then +c +c Left offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 +c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to +c interbeams = internotes*2/3. +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c End stickyS. Grab data now from prior note, since we have to shut off stickyS. +c + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + stickyS = .false. + go to 2 + end if +c +c If durq .ne. ':' then iccount is now on the start of the number +c + call readnum(lineq,iccount,durq,dum) + call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2)) + if (durq .eq. ':') then + stickyS = .true. + else + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. ',') then +c +c 2:1 pattern +c + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. 'o') then +c +c Suppress rest centering +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25) + go to 2 + else if (durq .eq.'L') then +c +c With keyboard rest option, look left +c + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'A') then +c +c Accidental option +c + call getchar(lineq,iccount,durq) +c + if (durq .eq. 'o') then +c +c Ordered accidentals in a chord. Mark the main note. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28) + else +c +c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29) + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + print*,'Illegal character in note: ',durq,', ivx,nn:', + * ivx,nnl(ivx) + call stop1() + end if +c +c Done with note/rest options. Set level and duration. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + do 43 npreslur = npreslur , 1 , -1 +c +c Set level for preslur on normal note, non-chord +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +43 continue + end if + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (btest(islur(ivx,nnl(ivx)),19)) then +c +c Set duration of full-bar rest as pause +c + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + else if (ibarmbr.ne.nbars+1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + if (btest(islur(ivx,nnl(ivx)),3)) + * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + end if + if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then +c +c Shift is on, and this is not first shifted note. Check for duration change +c + if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then +c +c Must stop and restart the offset. +c + irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1) + end if + end if + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (autofbon .and. tautofb.gt.tol .and. fbon) then +c +c Check to see if need to terminate auto forced beam +c + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Terminate autofb +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + end if + end if + if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then +c +c Finished a bar +c + nbars = nbars+1 + nib(ivx,nbars) = nnl(ivx) + if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then +c +c Just finished the pickup bar for this voice. +c + lenbar = lenb1 + end if + end if + if (idotform .eq. 1) then + call getchar(lineq,iccount,charq) + idotform = 2 + numnum = 1 + go to 28 + else if (idotform .eq. 3) then + call getchar(lineq,iccount,charq) + idotform = 4 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then +c +c Chord note. Must have note name, may have octave#,+,-,s,f,n,d +c Actually the 'd' is not used, since time value comes from +c basic note. Unless dot is to be shifted! +c Doesn't increase # of notes, so must handle separately +c ncrd: index of crd +c Set bit 10 of ipl on main note as flag +c Bits in icrdat: +c 0-7 ip within voice +c 8-11 ivx +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Cautionary accidental +c +c Bits in icrdot: +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx) + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdot(ncrd) = 0 + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +25 call getchar(lineq,iccount,durq) +c ndx = index('fsn+-<>12345678rediA',durq) + ndx = index('fsn+-<>12345678rediAc',durq) + if (ndx .eq. 20) then +c +c Expect +|-|<|> , set tag, loop +c + icrdat(ncrd) = ibset(icrdat(ncrd),29) + go to 25 + else if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 21) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (ndx .le. 7) then +c +c +/-/ Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental on chord note +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else if (durq .eq. 'd') then +c +c Must keep 'd' optional (backward compatibility), unless it is moved! +c + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) + * .eq. 0) go to 25 + icrdat(ncrd) = ibset(icrdat(ncrd),26) + call getchar(lineq,iccount,durq) + iccount=iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '+') then + icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64) + else + icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64) + end if + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift specified also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '+') then + ifnum = nint(fnum*10)+64 + else + ifnum = -nint(fnum*10)+64 + end if + else + ifnum = 64 + end if + icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7)) + iccount = iccount-1 + end if + else +c +c must be a single digit, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 25 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 44 npreslur = npreslur , 1 , -1 + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Set level for chord note. +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0) + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0) + isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +44 continue + if (notcrd) then +c +c This is the first chord note in this chord. +c + minlev = min(nolev(ivx,nnl(ivx)),lastlev) + maxlev = max(nolev(ivx,nnl(ivx)),lastlev) + else + minlev = min(minlev,lastlev) + maxlev = max(maxlev,lastlev) + end if + notcrd = .false. + else if (charq .eq. 'G') then + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + continue +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c +c ngrace = ngrace+1 +c ivg(ngrace) = ivx +c ipg(ngrace) = nnl(ivx)+1 +c if (ngrace .eq. 1) then +c ngstrt(ngrace) = 1 +c else +c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) +c end if +c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) +c nng(ngrace) = 1 +c multg(ngrace) = 1 +c upg(ngrace) = .true. +c slurg(ngrace) = .false. +c slashg(ngrace) = .false. +c18 call getchar(lineq,iccount,charq) +c if (index('WA',charq) .gt. 0) then +cc +cc Grace is on note that was already done, so shift flags forward one note. +cc This puts flag on actual note with grace; later for W will go ahead one more. +cc +c ipg(ngrace) = nnl(ivx) +c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) +c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) +c if (slurg(ngrace)) +c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) +c if (charq .eq. 'A') then +cc +cc close After, clear way-after bit, to ensure priority of most recent A/W +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) +c else +cc +cc Way after; later assign to following note, and position like normal grace. +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) +c end if +c else if (charq .eq. 'm') then +c call getchar(lineq,iccount,charq) +c multg(ngrace) = ichar(charq)-48 +c else if (index('123456789',charq) .gt. 0) then +c call readnum(lineq,iccount,durq,fnum) +c iccount = iccount-1 +c nng(ngrace) = nint(fnum) +c else if (charq .eq. 'l') then +c upg(ngrace) = .false. +c else if (charq .eq. 's') then +c slurg(ngrace) = .true. +c if (nnl(ivx) .gt. 0) then +cc +cc If A- or W-grace, set signal to start slur on main note. +cc +c if(btest(ipl(ivx,nnl(ivx)),31) .or. +c * btest(ipl(ivx,nnl(ivx)),29)) +c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) +c end if +c else if (charq .eq. 'x') then +c slashg(ngrace) = .true. +c else if (charq .eq. 'u') then +c else if (charq .eq. 'X') then +cc +cc Space before main note of grace. Number will come next. +cc +c iccount = iccount+1 +c call readnum(lineq,iccount,durq,graspace(ngrace)) +c iccount = iccount-1 +c end if +c if (index('abcdefg',charq) .eq. 0) go to 18 +cc +cc At this point, charq is first note name in grace +cc +c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 +c naccg(ing) = 0 +c ioct = 0 +c if (ing .gt. ngstrt(ngrace)) then +c55 call getchar(lineq,iccount,charq) +c if (charq .eq. ' ') go to 55 +c endif +c iclastlev = 0 +c9 call getchar(lineq,iccount,durq) +c if (durq .ne. ' ') then +c if (durq.eq.'+') then +c lastlev = lastlev+7 +c iclastlev = iclastlev+7 +c else if (durq.eq.'-') then +c lastlev = lastlev-7 +c iclastlev = iclastlev-7 +c else if (index('fsn',durq) .gt. 0) then +c if (naccg(ing) .eq. 0) then +c naccg(ing) = index('fsn',durq) +c else +cc +cc Double accidental +cc +c naccg(ing) = ibset(naccg(ing),2) +c end if +c else +c ioct = ichar(durq)-48 +c end if +c go to 9 +c end if +c if (ioct .gt. 0) then +c lastlev = ifnolev(charq,ioct) +c else +c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c lastlev = ndlev(iv,kv)+iclastlev +c end if +c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) +c end if +c nolevg(ing) = lastlev +c19 continue +cc +cc Grace could come before first note of block, so reset end level. +cc +c if (nnl(ivx).eq.0) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c ndlev(iv,kv) = lastlev +c end if + else if (charq .eq. sq) then +c +c Literal TeX string +c + call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount) + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. Symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)), + * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx, + * .true.,notcrd,nole) + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx) + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detect preslur on normal non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') + * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx) + ArpShift(NumArpShift) = fnum + end if + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx), + * nodur(ivx,nnl(ivx)),figq(ivf,nfig1), + * ivupfig(ivf,nfig1),nfigs(ivf)) + else if (charq .eq. '[') then +c +c Start forced beam. Record barno & time since start of inp. blk. Set signal +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + nadj = 0 + if (autofbon) then + autofbon = .false. + end if +17 call getchar(lineq,iccount,charq) + if (index('ulf',charq) .gt. 0) then + ulfbq(ivx,nfb(ivx)) = charq + go to 17 + else if (charq .eq. 'j') then +c +c Continuing a jumped beam here +c + irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24) +c +c Set flag to watch for END of this forced beam, so can set flag rest(30) on +c NEXT note as signal to start a new notes group there. +c + isbj2 = .true. + go to 17 + else if (charq .eq. 'h') then + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2) + go to 17 + else if (charq .eq. 'm') then +c +c Force multiplicity. Next input is digit +c + call getchar(lineq,iccount,charq) + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) + call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48) + go to 17 + else if (charq .eq. ':') then +c +c Start auto forced beam pattern +c + autofbon = .true. +c +c When forced later beam ends, check whether tautofv <=0; if so set it. +c + tautofb = -itsofar(ivx) + t1autofb = itsofar(ivx) + go to 17 + else if (charq .ne. ' ') then +c +c Must be '+/-' for height or slope shift +c + nadj = nadj+1 +c +c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + iadj = nint(fnum) + if (charq .eq. '-') iadj = -iadj + if (nadj .eq. 1) then +c +c This is a level shift. Note if 0 was entered, iadj = 30 +c + call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30) + else if (nadj .eq. 2) then +c +c Must be a slope shift +c + call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30) + else +c +c Beam-thk fine tune +c + call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj) + end if + go to 17 + end if + else if (charq .eq. ']') then + if (autofbon .and. tautofb.lt.tol) then + tautofb=itsofar(ivx)+tautofb + end if + call getchar(lineq,iccount,charq) + if (index('j ',charq) .gt. 0) then +c +c Since ']' comes AFTER note, itsofar has been updated. Set ending signal. +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + if (charq .eq. 'j') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23) + if (isbj2) then +c +c This is the end of a fb segment of a jump beam. Set flag on NEXT note to +c force start of new notes group, provided this is not last note in bar. +c + if (mod(itsofar(ivx),lenbar) .ne. 0) + * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30) + isbj2 = .false. + end if + else if (charq .eq. '[') then +c +c Multiplicity down-up signal +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) + else if (charq .eq. '-') then +c +c Set signals for gap in single-slope beam [...]-[...] +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20) + nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21) +c +c Next two characters must be "[ ". Skip over them. +c + iccount = iccount+2 + end if + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)), + * iornq(ivx,nnl(ivx)),lineq,iccount) + else if (charq .eq. 'h') then +c +c Heading or height. For heading, only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "h" not at beginning of block' + call stop1() + end if + call getchar(lineq,iccount,durq) + ihdvrt = 0 + if (index('+-',durq) .gt. 0) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ihdvrt = fnum+.1 + if (durq .eq. '-') ihdvrt = -ihdvrt + durq = charq + end if + if (durq .ne. ' ') then +c +c Height symbol. Read past (until next blank) +c +3 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 3 + else +c +c Set flag for header & read it in +c + ihdht = 16 + call getbuf(headrq) + iccount = 128 + end if + else if (charq .eq. 'L') then +c +c Linebreak, already handled in pmxa, but check for movement break +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fmovbrk) + if (durq .eq. 'P') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + end if + if (durq .eq. 'M') then + movbrk = nint(fmovbrk) + movgap = 0 + parmov = -1. + call getchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Get vertical space (\internotes) +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + movgap = nint(fnum) + go to 31 + else if (durq .eq. 'i') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,parmov) + go to 31 + else if (durq .eq. 'c') then + nobar1 = .true. + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then +c +c "rename" can be set on or off. +c + call getchar(lineq,iccount,durq) + rename = durq.eq.'+' + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iiorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iiorig in original list of instruments. +c + nvold = nv + nv = 0 + rename = .true. + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')ninow + else + ninow = ichar(durq)-48 + end if + iiv = 0 + do 63 iinow = 1 , ninow + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow) + else + iiorig(iinow) = ichar(durq)-48 + end if + nspern(iinow) = nsperi(iiorig(iinow)) + nv = nv+nspern(iinow) + sepsymq(iiv+nspern(iinow)) = '&' + if (nspern(iinow) .gt. 1) then + do 64 iis = 1 , nspern(iinow)-1 + sepsymq(iiv+iis) = '|' +64 continue + end if + iiv = iiv+nspern(iinow) +63 continue + 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 (nv.eq.1 .and. nvold.gt.1) then + if (islast) write(11,'(a)')sq//'nostartrule' + else if (nv.gt.1 .and. nvold.eq.1) then + if (islast) write(11,'(a)')sq//'startrule' + end if + iiv = 0 + do 60 iinow = 1 , ninow + do 61 iis = 1 , nspern(iinow) + iiv = iiv+1 +c +c May not really need to re-enter clefs, but it's easier to program since +c clef names are not saved but are needed in newvoice to set ncmidcc. +c + call getchar(lineq,iccount,clefq(iiv)) + call newvoice(iiv,clefq(iiv),.true.) + if (nspern(iinow) .eq. 1) then + hdlndq = chax(48+numclef(clefq(iiv))) + lclf = 1 + else if (iis .eq. 1) then + hdlndq = '{'//chax(48+numclef(clefq(iiv))) + lclf = 2 + else if (iis .lt. nspern(iinow)) then + hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv))) + lclf = lclf+1 + else + hdlndq = + * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}' + lclf = lclf+2 + end if +61 continue +c +c setstaffs & setclef go by instrument, not voice +c + if (islast) then + if (iinow .lt. 10) then + write(11,'(a)')sq//'setstaffs' + * //chax(48+iinow)//chax(48+nspern(iinow))//'%' + write(11,'(a)')sq//'setclef'//chax(48+iinow) + * //hdlndq(1:lclf)//'%' + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinow, + * '}'//chax(48+nspern(iinow))//'%' + write(11,'(a9,i2,a)')sq//'setclef{',iinow, + * '}'//hdlndq(1:lclf)//'%' + end if + end if +60 continue +c +c Loop back up, this may not be last option in M. Note flow out if durq=' ' +c + call getchar(lineq,iccount,durq) + go to 31 + end if +c +c Write instrument names +c + if (.not.rename) then + do 62 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' + else + write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%' + end if + end if +62 continue + else + do 65 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst,'{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + end if + end if +65 continue + rename = .false. + end if + end if + else if (charq .eq.'|' ) then +c +c End of bar symbol. Check about end of bar hardspace. +c + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by a bar line. Remove it from the hardspace +c list, store with shifts instead, set special bit. Need to repeat this code +c at '/'. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + else if (index('wS',charq) .gt. 0) then +c +c Width symbol or new nsyst. Read past (until blank) +c +4 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 4 + else if (charq .eq. 'l') then +c +c Lower string. Only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "l" not at beginning of block' + call stop1() + end if +c +c Set flag for lower string & read it in +c + lower = .true. + call getbuf(lowerq) + iccount = 128 + else if (charq .eq. 'm') then +c +c Meter change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "m" not at beginning of block' + call stop1() + end if + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + call readmeter(lineq,iccount,mtrnmp,mtrdnp) + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenbar = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenbar = lenbar*2 + lenb1 = lenbar + lenb0 = 0 + if (ismidi) call midievent('m',mtrnuml,mtrdenl) + else if (charq .eq. 'C') then +c +c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. +c + if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 + tcc(iv,ncc(iv)) = itsofar(iv) + isl = ibset(islur(iv,nnl(iv)+1),11) + call getchar(lineq,iccount,durq) +c +c Store clef number, or 7 if clef number = 9 (French violin clef) +c + isl = ior(isl,ishft(min(numclef(durq),7),12)) + ncmidcc(iv,ncc(iv)) = ncmidf(durq) +c +c Set marker on note with lowest voice # starting at same time. +c + if (iv .eq. 1) then + isl = ibset(isl,15) + else + do 13 iiv = 1 , iv + nnliiv = nnl(iiv) + if (iiv .eq. iv) nnliiv = nnliiv+1 + itother = 0 + do 14 iip = 1 , nnliiv + if (itother .lt. itsofar(iv)) then + itother = itother+nodur(iiv,iip) + go to 14 + else if (itother .eq. itsofar(iv)) then + islur(iiv,iip) = ibset(islur(iiv,iip),15) + go to 15 + end if +14 continue +13 continue +15 continue + end if +c +c Need 'or' since may have set bit 15 in the above loop +c + islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) + else if (charq .eq. 'R') then +c +c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) +c +10 call getchar(lineq,iccount,durq) +c +c Save designator in case it's a terminal Rr or Rd +c + if (durq .eq. 'l') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5) + go to 10 + else if (index('rdDbz',durq) .gt. 0) then + if (durq .eq. 'r') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6) + else if (durq .eq. 'd') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8) + else if (durq .eq. 'D') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26) + else if (durq .eq. 'b') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25) + else if (durq .eq. 'z') then + iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) + end if + rptprev = .true. + rptfq1 = durq + go to 10 + end if + else if (charq .eq. 'V') then +c +c Ending +c + nnnl = nnl(1)+1 + lvoltxt = 0 +11 call getchar(lineq,iccount,durq) + if (durq.eq.'b' .or. durq .eq.'x') then +c +c End Volta, set bit9, and bit10 on if 'b' (end w/ box) +c + islur(1,nnnl) = ibset(islur(1,nnnl),9) + if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10) + go to 11 + else if (durq .ne. ' ') then +c +c Start volta; Get text +c + if (lvoltxt .eq. 0) then +c +c First character for text +c + lvoltxt = 1 + islur(1,nnnl) = ibset(islur(1,nnnl),7) + nvolt = nvolt+1 + voltxtq(nvolt) = durq + else + voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq + lvoltxt = lvoltxt+1 + end if + go to 11 + end if + else if (charq .eq. 'B') then + bcspec = .not.bcspec + else if (charq .eq. 'P') then +c +c Page numbers. Print stuff right now. +c + npg1 = 0 +c +c Will use ltopnam to signal whether there's a centered heading +c + ltopnam = 0 + ipg1r = 0 +16 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48 .and. ichar(durq).le.57) then + npg1 = npg1*10+ichar(durq)-48 + go to 16 + else if (durq .eq. 'l') then + if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1 + go to 16 + else if (durq .eq. 'r') then + if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1 + go to 16 + else if (durq .eq. 'c') then +c +c Top-centered name. Assume this is last option. Read the name. +c May surround name in double quotes (to allow blanks). +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + ltopnam = lenstr(cheadq,60) + else + namstrt = iccount + if (durq .eq. '"') then +c +c Using quote delimiters. +c + quoted = .true. + namstrt = namstrt+1 + else + quoted = .false. + end if + do 35 iccount = namstrt+1, 128 + if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. + * (.not.quoted .and. lineq(iccount:iccount) .eq. ' ')) + * go to 36 +c +c On exit, iccount is OK, and name is in (namstrt:iccount-1) +c +35 continue + print*,'Awww, cmon, should not be here.' + call stop1() +36 continue + ltopnam = iccount-namstrt + cheadq = lineq(namstrt:iccount-1) + end if + end if +c +c Done getting data, now assemble the command +c + if (npg1.eq.0) npg1=1 +c +c 2/23/03 Don't use \atnextline if on first page and only one system +c +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{' + lhead = 27 +c else +c hdlndq = sq//'toppageno{' +c lhead = 11 +c end if + if (npg1 .lt. 10) then +c +c Note we are overwriting the last "{" +c + write(hdlndq(lhead:lhead),'(i1)')npg1 + else if (npg1 .lt. 100) then + lhead = lhead+3 + write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}' + else + lhead = lhead+4 + write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}' + end if + hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{' + lhead = lhead+2 +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + 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 +c else +c if (ltopnam .eq. 0) then +c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' +c else +c if (islast) +c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' +c end if +c end if + else if (charq .eq. 'W') then +c +c Just eat the number that must follow, it was used in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else if (charq .eq. 'T') then + headlog = .true. + inhead = 0 + call getchar(lineq,iccount,durq) + if (durq .eq. 'i') then + call getbuf(instrq) +c +c A kluge for parts from separate score file for later movements. +c + if (instrq(1:1) .eq. ' ') headlog = .false. + cheadq = instrq + else if (durq .eq. 't') then + call getchar(lineq,iccount,durq) +c +c Optionally can include extra vertical \internotes above inbothd +c + if (index('-+0123456789',durq) .gt. 0) then + ipm = 1 + if (index('+-',durq) .gt. 0) then +c +c Don't trust readnum to round this negative integer properly +c + iccount = iccount+1 + if (durq .eq. '-') ipm = -1 + end if + call readnum(lineq,iccount,durq,fnum) + inhead = ipm*nint(fnum) + end if + call getbuf(titleq) + else + call getbuf(compoq) + end if + inhead = inhead+inbothd + iccount = 128 + else if (charq .eq. 'A') then +c +c Accidental handling etc. +c +27 call getchar(lineq,iccount,durq) + if (durq .eq. 'r') then + if (islast) then + relacc = .true. + write(11,'(a)')sq//'relativeaccid%' + end if + else if (durq .eq. 's') then + bacfac = 1.e6 + else if (durq .eq. 'b') then + if (islast) write(11,'(a)')sq//'bigaccid%' + accfac = bacfac + else if (durq .eq. 'a') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + else if (durq .eq. 'i') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,tintstf) + if (.not.firstgulp) fintstf = tintstf +c +c Local corrections for first page were handled by pmxa +c + iccount = iccount-1 + else if (durq .eq. 'I') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + else if (durq .eq. 'd') then + lowdot = .true. + else if (durq .eq. 'o') then + continue + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call getchar(lineq,iccount,durq) + if (index('-s',durq) .gt. 0) then + fullsize(iiv) = 0.8 + else if (durq .eq. 't') then + fullsize(iiv) = 0.64 + else + fullsize(ivx) = 1.0 + end if +50 continue + else if (durq .eq. 'e') then +c +c Line-spacing equalization +c + equalize = .true. +c +c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. +c But it causes problems with some older scores and when excerpts are combined +c with LaTeX. So as of 2.352 we write it here. +c + write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq + * //'Interligne minus 99'//sq//'Interligne%' + tempq = sepsymq(1) + lentemp = 1 + do 51 iiv = 2 , nv-1 + tempq = tempq(1:lentemp)//sepsymq(iiv) + lentemp = lentemp+1 +51 continue + write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes' + * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}' + * //sq//'en}%' + else if (durq .eq. 'v') then +c +c Toggle usevshrink +c + usevshrink = .not.usevshrink + else if (durq .eq.'p') then +c +c Postscript slurs. fontslur is already false (set in g1etnote) +c + if (.not.WrotePsslurDefaults) then +c +c Set postscrirpt slur adjustment defaults +c + write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust' + * //sq//'nohalfties' + WrotePsslurDefaults = .true. + end if +52 continue + call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l" + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c" + if (durq .eq. '+') then + if (charq .eq. 's') then + write(11,'(a)')sq//'Sluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Tieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'halfties' + else + SlurCurve = SlurCurve + 1 + if (SlurCurve .gt. 3.1) then + call printl('WARNING!') + call printl + * ('Default slur curvature advanced past HH, resetting') + SlurCurve = 3 + end if + end if + else + if (charq .eq. 's') then + write(11,'(a)')sq//'Nosluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Notieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'nohalfties' + else + SlurCurve = SlurCurve - 1 + if (SlurCurve .lt. -1.1) then + call printl('WARNING!') + call printl( + * 'Default slur curvature decremented below f, resetting') + SlurCurve = -1 + end if + end if + end if + go to 52 ! Check for another set of default changes + else if (durq .eq. 'l') then +c +c Set optional linebreak ties +c + OptLineBreakTies = .true. + go to 52 + else if (durq .eq. 'h') then +c +c Set flag to write header special on every page +c + HeaderSpecial = .true. + go to 52 + else + iccount = iccount-1 + end if + else if (durq .eq. 'K') then +c +c Toggle keyboard rest placement flag +c + kbdrests = .not.kbdrests + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) +c +c Just eat the input; it was used in pmax +c + go to 27 + end if + if (index('NR',durq) .gt. 0) then +c +c Override default part names for scor2prt, or normal include file. +c Just bypass rest of input line +c + iccount = 128 + else if (durq .ne. ' ') then + go to 27 + end if + else if (charq .eq. 'K') then + call getchar(lineq,iccount,durq) + if (durq .ne. 'i') then +c +c Normal, full-score key change and/or transposition +c + num1 = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = num1*nint(fnum) +c +c On exit, durq='+','-'. But only need isig if after start, else done in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (num1 .eq. 0) then +c +c Key change, not transposition. +c + ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28) + lastisig = isig + isig = nint(fnum) + if (durq .eq. '-') isig = -isig + isig = isig+idsig + if (ismidi) call midievent('k',isig,0) + else +c +c num1 .ne. 0, so transposition, so must be at beginning. isig came with K... +c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data +c (signature before transposition). idsig must be added to future key changes. +c + jv = 0 + do while (jv .lt. nm) + jv = jv+1 + iTransAmt(jv) = num1 + end do + idsig = isig-isig0 + end if + else +c +c Instrument specific transposition. + + call GetiTransInfo(.false.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '/') then + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by end of block. Remove it from the hardspace +c list, store with shifts instead, set special bit. This code also at '|' +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + call getchar(lineq,iccount,durq) +c +c Save ending note level: +c + if (ivx .le. nv) then +c +c This is the first line of music on this staff. If previous block had only 1 +c voice, save last pitch from line 1 of prev. block to line 2, in case a +c 2nd line is started just below +c + if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1) + was2(iv) = .false. + ndlev(iv,1) = lastlev + else +c +c This is the 2nd line of music on this staff. +c + was2(iv) = .true. + ndlev(iv,2) = lastlev + end if + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new line of music +c + if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0 + nbars = 0 + if (durq .eq. ' ') then +c +c New line of music is on next staff +c + iv = iv+1 + ivx = iv + else +c +c durq must be 2nd '/'. New line of music is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + nfb(ivx) = 0 + nudoff(ivx) = 0 + ndotmv(ivx) = 0 + do 24 j = 1 , 200 + irest(ivx,j) = 0 + islur(ivx,j) = 0 + nacc(ivx,j) = 0 + iornq(ivx,j) = 0 + ipl(ivx,j) = 0 + mult(ivx,j) = 0 +24 continue +c +c Go back and lower the rests in voice "a" that don't have over-ridden heights +c + do 26 j = 1 , nnl(iv) + if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0) + * nolev(iv,j) = -4 +26 continue + end if + end if + iccount = 128 + else if (charq .eq. 'X') then +c +c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, +c which only happens for normal X at block start, and we took special measures to +c keep group shifts for crossing block boundaries. +c + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))), + * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx, + * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub) + else if (charq .eq. 'I') then +c +c Midi controls. +c + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.false.) + else if (charq .eq. 'M') then +c +c Macro action +c + call getchar(lineq,iccount,charq) + if (index('RS',charq) .gt. 0) then +c +c Record or save a macro. Get the number of the macro. +c + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call mrec1(lineq,iccount,ndxm) + else +c +c Save (Record but don't activate) +c +5 call mrec1(lineq,iccount,ndxm) + if (mrecord) then + call getbuf(lineq) + iccount = 0 + go to 5 + end if + iccount = iccount+ndxm+1 + end if + else if (charq .eq. 'P') then +c +c Playback the macro +c + call getchar(lineq,iccount,charq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + icchold = iccount + lnholdq = lineq + iccount = 128 + ilmac = il1mac(macnum) + mplay = .true. + end if + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Check for start of forced beam on 2nd member of dotform=1 shortcut +c + if (fbon) then + if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx)) + * t1fb(ivx,nfb(ivx)) = + * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2 + end if +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + end if + return + end + subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg, + * ip,ivx,noxtup,notcrd,nole) +c +c iornq: Main note. Do not alter if chord note, except turn on bit 23 +c iornq0: Store iorni + bit 23, in case of repeated ornaments +c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. +c noffseg: horiz. offset for segno +c nole: level of note w/ orn, used to ID the note/orn if there's a level shift. +c + + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comcb/ nbc,ibcdata(36) + character*1 charq,durq + character*128 lineq + logical ornrpt,negseg,noxtup,notcrd +c +c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U +c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD +c + call getchar(lineq,iccount,charq) + if (index('bc',charq) .gt. 0) then +c +c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) +c ivx(0-3,28), ip(4-12), +c vshift (vshift+32 in bits 13-18), +c hshift (nint(10*vshift)+128 in bits 19-26) +c bit 27 = 0 if caesura, 1 if breath +c bit 28: 5th bit of ivx +c + iornq = ibset(iornq,28) + nbc = nbc+1 +c ibcdata(nbc) = ivx+16*ip + ibcdata(nbc) = mod(ivx,16)+16*ip + if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28) + if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27) + call getchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c We have a vertical shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),6,13,nint(32+fnum)) + if (index('+-',charq) .gt. 0) then +c +c Horizontal shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128) + end if + end if + return + end if +c +c Set signal on main note that some note at this time has ornament. ONLY used +c in beamstrt to activate further tests for whether ihornb is needed. +c + iornq = ibset(iornq,23) +c +c Isolate 21 bits defining exisiting ornaments +c + if (notcrd) then + iorni = iand(4194303,iornq) + else + iorni = iand(4194303,icrdorn(ncrd)) + end if + korn = index('stmgx+Tupf._)e:XXX>^',charq) + if (korn .ne. 15) iorni = ibset(iorni,korn) +c +c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later +c as follows: korn=16-18 for sfn, and or 21 for bare ?. +c When this if-block is done, korn will = bit# of actual ornament (unless "?"). +c + if (korn .eq. 15) then +c +cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq +c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq +c +c iorni = ior(iorni,iand(iornq0,1638383)) + iorni = ior(iorni,iand(iornq0,3735535)) + ornrpt = .false. + call getchar(lineq,iccount,durq) +c +c durq will be ' ' +c + else if (korn .eq. 14) then +c +c Editorial accidental +c + call getchar(lineq,iccount,durq) +c korn = 15+index('sfn',durq) + korn = 15+index('sfn?',durq) + if (korn .eq. 19) korn=21 + iorni = ibset(ibclr(iorni,14),korn) + call getchar(lineq,iccount,durq) + if (durq .eq. '?') then +c +c This is "oe[s|f|n]?". Set 21st bit also. +c + iorni = ibset(iorni,21) + korn = korn+6 + call getchar(lineq,iccount,durq) + end if +c iorni = ibset(ibclr(iorni,14),korn) + else if (korn.eq.4 .and. noxtup) then +c +c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points +c + noffseg = 0 + negseg = .false. + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Segno shift is specified +c + if (durq .eq. '-') then + negseg = .true. + call getchar(lineq,iccount,durq) + end if + call readnum(lineq,iccount,durq,fnum) + noffseg = int(fnum) + if (negseg) noffseg = -noffseg + end if + else if (korn .eq. 7) then +c +c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = ip + xnsktr(ntrill) = 1. + call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Convert to new internal symbol for non-'"tr" trill +c + korn = 15 + iorni = ibset(ibclr(iorni,7),15) + call getchar(lineq,iccount,durq) + end if + if (index('0123456789.',durq) .gt. 0) then +c +c We have a number for the length +c + call readnum(lineq,iccount,durq,xnsktr(ntrill)) + end if + else if (korn.eq.10 .and. noxtup) then +c +c Fermata +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'd') then + korn = 14 + iorni = ibset(ibclr(iorni,10),14) + call getchar(lineq,iccount,durq) + end if + else + call getchar(lineq,iccount,durq) + end if + if (index('+- :',durq) .eq. 0) then + print*,'Unexpected character at end of ornament: ',durq + call stop1() + end if + if (index('+-',durq) .gt. 0) then +c +c Shift ornament up or down +c + nudorn = nudorn+1 +c +c Set bit 25 in iorni as a signal. This may not really be necessary. +c + iorni = ibset(iorni,25) +c +c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, +c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present +c + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iofforn = nint(xofforn*fnum) + kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12) + * +ishft(korn,19)+ishft(iofforn+32,25) + ivxudorn(nudorn) = ivx + if (index('+-',durq) .gt. 0) then +c +c Horizontal shift +c + kudorn(nudorn) = ibset(kudorn(nudorn),31) + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ornhshft(nudorn) = nint(xofforn*fnum) + end if + else if (durq .eq. ':') then +c +c Turn on repeated ornaments +c + ornrpt = .true. +c +c Save the ornament value just set +c + iornq0 = iorni + end if + if (notcrd) then + iornq = ior(iornq,iorni) + else + icrdorn(ncrd) = ior(icrdorn(ncrd),iorni) + end if + return + end + subroutine getpmxmod(global,includeq) +c +c If global=.true., checks for environment variable with path to pmx.mod. +c Then, if variable exists and points to pmx.mod, insert lines from +c pmx.mod into buffer +c If global=.false., checks for existence of includeq and uses it. +c +c lenbuf0 = total length of bufq on entry +c lbuf(i) = length of line (i) +c nlbuf = number of lines stored in bufq +c ilbuf = index of first line after setup stuff (on entry). In general, index of +c next line to be sucked from buffer. +c ilbufmod = counter for lines in pmx.mod as they are grabbed. +c Starts at ilbuf. Points to position of next line after +c pmx.mod stuff in bufq on exiting loop 1 +c ilbuff = transient counter for shifting operations +c ipbuf = on entry, points to last character in setup stuff. In general, points +c to last character of most recent line sucked from buffer. +c ipbufmod = points to last character of most recent inserted line +c from pmx.mod +c + parameter (maxblks=4000,nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,fbon,issegno,isheadr,isvolt + character*(*)includeq + character*80 pmxmoddirq + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical fexist,global + line1pmxmod = ilbuf + if (.not.global) then + inquire(file=includeq,EXIST=fexist) +c +c Transfer includeq to temporary char variable with known length +c + pmxmoddirq = includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + print* + write(15,'()') + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', checking further.') +c +c File named includeq doesn't not exist. Get directory from PMXMODDIR and +c see if it's there +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq. gt. 0) then + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + else + call printl( + * 'No other directory defined by PMXMODDIR, stopping') + call stop1() + end if + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', stopping.') + call stop1() + end if + end if + call printl('Opening normal include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq) + else +c +c Check for existence of pmx.mod +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq .eq. 0) return + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod' + lpmxmoddirq = lpmxmoddirq+7 + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) return + call printl('Opening global include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq(1:lpmxmoddirq)) + end if + call printl('Adding include data') +c +c Read lines in from pmx.mod one at a time +c + ipbufmod = ipbuf + lenbufmod = lenbuf0 + do 1 ilbufmod = ilbuf , maxblks + read(18,'(a)',end=3)lnholdq +c +c A line was read. Slide all existing lengths from here forward ahead by 1 +c + do 2 ilbuff = nlbuf , ilbufmod , -1 + lbuf(ilbuff+1) = lbuf(ilbuff) +2 continue +c +c Get length of line from include file +c + lenmodline = lenstr(lnholdq,128) + if (lenmodline .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lenmodline = 1 + lnholdq = ' ' + end if + lbuf(ilbufmod) = lenmodline + call printl(lnholdq(1:lenmodline)) +c +c Insert new stuff into bufq +c + bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)// + * bufq(ipbufmod+1:lenbufmod) +c +c Update internal parameters +c + ipbufmod = ipbufmod+lbuf(ilbufmod) + lenbufmod = lenbufmod+lbuf(ilbufmod) + nlbuf = nlbuf+1 +1 continue +3 continue + call printl('Closing '//pmxmoddirq(1:lpmxmoddirq)) + close(18) + linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf + lenbuf0 = lenbufmod +c +c Fix Andre's error reporting problem 101211 leading to log(neg#) due +c to nline being 2 bigger than it should be +c + nline=nline-2 +c + return + end + subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0, + * inameq,clefq,sepsymq,pathnameq,lpath,isig0) + parameter (nm=24) + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*1 clefq(nm),sepsymq(nm) + character*40 pathnameq + character*79 inameq(nm) + character*128 lineq + logical istype0,newway,rename +c +c Get the first line +c + iccount = 0 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 9 + istype0 = lineq(1:3).eq.'---' + if (istype0) then +c +c Have TeX input until next line that starts with '---'. Save in scratch. +c + open(17,status='SCRATCH') +3 call getbuf(lineq) + if (lineq(1:3) .ne. '---') then + write(17,'(a)')lineq + go to 3 + end if +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq is first line w/ numerical setup data. +c + nv = nint(readin(lineq,iccount,nline)) + noinst = nint(readin(lineq,iccount,nline)) + newway = noinst.le.0 + if (newway) noinst = -noinst + do 2 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then +c +c Read in nvi for each instrument +c + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if + iiorig(iinst) = iinst + nspern(iinst) = nsperi(iinst) +2 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge to make mtrdenl work +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + xmtrnum0 = readin(lineq,iccount,nline) +c +c Original key sig (before any trnasposition) in next position. Transposed +c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key +c changes if transposed. +c + isig0 = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musicsize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , noinst +5 call getbuf(inameq(i)) + if (inameq(i)(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 6 + iv = 0 + nvsofar = 0 + do 1 jinst = 1 , noinst + nvsofar = nvsofar+nsperi(jinst) + do 10 ivi = 1 , nsperi(jinst) + iv = iv+1 + clefq(iv) = lineq(iv:iv) + if (iv .eq. nvsofar) then + sepsymq(iv) = '&' + else + sepsymq(iv) = '|' + end if +10 continue +1 continue +c +c Mext non-comment line has path name +c +8 call getbuf(pathnameq) + if (pathnameq(1:1) .eq. '%') go to 8 + lpath = index(pathnameq,' ')-1 + return + end + function getsquez(n,ntot,space,tnote,to) + real*4 tnote(600),to(600) + common /comtol/ tol +c +c Get the squez factor by checking space against tgovern=minimum duration +c of all notes sounding at time of n-th note in the list. +c The starting time of base increment is to(n) and ending time is to(n)+space +c Sounding notes are those that start at or before to(n) .and. end at or +c after tend=to(n)+space +c Since notes are ordered by increasing start times, as soon as we find one +c that starts too late, we are done checking. +c + tgovern = 1000. + tend = to(n)+space + do 1 in = 1 , ntot +c +c Since to() is ordered by start times, exit loop after first note that +c starts later than note of interest. +c + + if (to(in) .gt. to(n)+tol) go to 2 + if (to(in)+tnote(in) .gt. tend-tol) then +c +c If here, this note overlaps and must be tested. +c + tgovern = min(tgovern,tnote(in)) + end if +1 continue +2 continue + getsquez = space/tgovern + return + end + subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx, + * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub) + parameter(nm=24) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c Since during getnote phase time is integer itsofar, which is not updated +c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if +c not in xtup. +c + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical shifton,colon,ess,number + character*128 lineq + character*1 charq,durq,dotq + colon = .false. + ess = .false. + number = .false. + nextbl = iccount+index(lineq(iccount:128),' ')-1 + if (index(lineq(iccount:nextbl),'P') .gt. 0) then +c +c "Parts only", ignore entire symbol +c + iccount = nextbl + return + end if +1 call getchar(lineq,iccount,charq) + if (charq.eq.'B') then +c +c "Both parts and score," ignore character +c + go to 1 + else if (charq .eq. ':') then + colon = .true. + go to 1 + else if (charq .eq. 'S') then + ess = .true. + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (charq.eq.'-') iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum = -fnum + if (durq .ne. 'p') then + fnum = fnum*wheadpt + iccount = iccount-1 + end if + go to 1 + end if +c +c charq must be blank, so done parsing +c + if (.not.ess .and. .not.colon) then +c +c Ordinary hardspace. Goes before next note. +c (Later, at "|" or "/", check for presence and switch to udoff if there!) +c + nudsp = nudsp+1 + iornq1 = ibset(iornq1,26) + udsp(nudsp) = fnum + tudsp(nudsp) = itsofar + if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp) +c * +float(itup-1)/ntup*ifnodur(nnodur,dotq) + * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq) + else if (.not.number) then +c +c Must be "X:" End a group offset. +c + irest = ibset(irest,17) + shifton = .false. + return + else +c +c Only other possibility is start offset, "S" for single, ':' for multiple +c + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = fnum + if (ess) then + irest1 = ibset(irest1,15) + else + irest1 = ibset(irest1,16) + shifton = .true. + end if + end if + return + end + function i1fnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + i1fnodur=1 + else if (idur .eq. 3) then + i1fnodur=2 + else if (idur .eq. 1) then + i1fnodur=4 + else if (idur .eq. 8) then + i1fnodur=8 + else if (idur .eq. 4) then + i1fnodur=16 + else if (idur .eq. 2) then + i1fnodur=32 + else if (idur .eq. 0) then + i1fnodur=64 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + i1fnodur=4 + else if (idur .eq. 9) then + i1fnodur = 128 + else + print* + print*,'You entered an invalid note-length value:',idur + call stop1() + end if + if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2 + return + end +c integer*4 function longi(ishort) +c integer*2 ishort +c longi = ishort +c return +c end + function iashft(nacc) + integer*4 ias(6) + data ias /-1,1,0,0,-2,2/ + iashft = ias(nacc) + return + end + function ifnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + ifnodur=1 + else if (idur .eq. 3)then + ifnodur=2 + else if(idur .eq. 1) then + ifnodur=4 + else if(idur .eq. 8) then + ifnodur=8 + else if(idur .eq. 4) then + ifnodur=16 + else if(idur .eq. 2) then + ifnodur=32 + else if(idur .eq. 0) then + ifnodur=64 + else if(idur .eq. 9) then + ifnodur=128 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + ifnodur=4 + else + print*,'You entered an invalid note value' + stop + end if + if (dotq .eq. 'd') ifnodur = ifnodur*3/2 + return + end + function ifnolev(noq,oct,ntrans) + character*1 noq + integer oct + ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans + return + end +c subroutine report(nsdat,isdat1,isdat2) +c integer*4 isdat1(202),isdat2(202) +c write(*,'(a)') +c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' +c do 1 isdat = 1 , nsdat +c isdata = isdat1(isdat) +c ionoff = igetbits(isdata,1,11) +cc iv = iand(7,isdata) +c iv = igetbits(isdata,5,13) +c kv = igetbits(isdata,1,12)+1 +c ip = igetbits(isdata,8,3) +c idcode = igetbits(isdata,7,19) +c iud1 = igetbits(isdata,1,26) +c iud2 = igetbits(isdata,1,27) +c ndxslur = igetbits(isdata,4,28) +c isdatb = isdat2(isdat) +c ivo = igetbits(isdatb,6,6)-32 +c iho = igetbits(isdatb,7,12)-64 +c lev = igetbits(isdatb,7,19) +c icrd = igetbits(isdatb,1,0) +c lhd = igetbits(isdatb,1,1) +c irhd = igetbits(isdatb,7,2) +c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, +c * ivo,iho,lev,icrd,lhd,irhd +c1 continue +c print* +c return +c end + function igetbits(isdata,iwidbit,ishift) +c +c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and +c then added to ioff +c + igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift)) + return + end + function igetvarlen(mmidi,icm,imidi,nbytes) +c +c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. +c + parameter (nm=24,mv=24576) + integer*2 mmidi(0:nm,mv) + igetvarlen = 0 + do 1 nbytes = 1 , 4 + igetvarlen = 128*igetvarlen + * +iand(127,mmidi(icm,imidi+nbytes)) +c * +iand(127,longi(mmidi(icm,imidi+nbytes))) + if (.not.btest(mmidi(icm,imidi+nbytes),7)) return +c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return +1 continue + print*,'Messup in igetvarlen' + call stop1() + end + logical function isdotted(nodur,ivx,ip) + parameter (nm=24) +c +c Function returns true if note is dotted or double-dotted. +c Return false for any xtuplet. +c + common /comtol/ tol + integer*4 nodur(nm,200) + if (nodur(ivx,ip) .eq. 0) then + isdotted = .false. + return + else if (ip .gt. 1) then + if (nodur(ivx,ip-1) .eq. 0) then + isdotted = .false. + return + end if + end if +c +c Ruled out all xtups, so is dotted or double-dotted if not a power of 2. +c + isdotted = + * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol + return + end + function isetvarlen(idur,nbytes) + isetvarlen = 0 + itemp = idur + do 1 nbytes = 1 , 4 + isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1) + itemp = ishft(itemp,-7) + if (itemp .gt. 0) then + isetvarlen = isetvarlen+2**(8*nbytes+7) + else + return + end if +1 continue + print*,'Problem in function isetvarlen' + call stop1() + end + subroutine istring(i,string,len) +c +c Returns string with integer only if length is 1, otherwise enclosed in +c brackets. +c + character*(*) string + if (i .ne. 0) then + len = alog10(abs(i)*1.0001)+1 + if (i .lt. 0) len = len+1 + else + string = '0' + len = 1 + return + end if + if (len .eq. 1) then + string = char(48+i) + else + string = '{' + write(string(2:1+len),'(i'//char(48+len)//')')i + string = string(1:len+1)//'}' + len = len+2 + end if + return + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + function levrn(nolev,irest,iud,ncm,mult) +c +c Used for placing numbers in xtups. Returns note level if not a rest, +c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. +c + logical btest + if (.not.btest(irest,0)) then + levrn = nolev + else +c +c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. +c + if (mult .gt. 0) then + if (mult .eq. 2) then + ioff = -1+2*iud + else if (mult .ne. 4) then + ioff = iud*mult + else + ioff = 1+4*iud + end if + else +c +c May need to futz with this later for non-beamed xtups (quarter, half rests) +c + ioff = iud*2 + end if + levrn = mod(nolev+20,100)-20+ncm+ioff + endif + return + end + function lfmt1(x) +c +c Computes total length of an "f" format with one decimal place. +c First round to nearest 0.1 +c + if (abs(x) .lt. .001) then + lfmt1 = 2 + else + y = sign(.1*int(10*abs(x)+.5),x) + lfmt1 = int(log10(1000*abs(y)+.001)) + if (y .lt. 0) lfmt1 = lfmt1+1 + end if + return + end + subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + parameter (nm=24) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie + character*1 udq,chax,sepsymq(nm) + character*8 noteq + character*128 notexq +c +c This is called twice from pmxb after having input an entire block, before +c making a bar that starts a new system. So nsdat reflects all slur starts +c and stops in new block, while listslur, which is only set when bars are +c made, reflects only open slurs from the old block. So we must check +c listslur to find open ties, not all nsdat. +c First of two calls (ispstie=.false. on entry) terminates tie at end of line. +c Second (ispstie=.true. on entry) restarts tie at start of new line. Only +c need data from original tie-start for both of these. Tie/slur data from +c closing of full tie are not used except for shape alterations. +c +c do 1 ndx = 0 , 11 + do 1 ndx = 0 , 23 + if (btest(listslur,ndx)) then +c +c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie +c + do 2 isdat = 1 , nsdat +c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index + if (igetbits(isdat1(isdat),4,28) + * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index + if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop + if (btest(isdat2(isdat),3)) go to 3 ! "st" + idcode = igetbits(isdat1(isdat),7,19) + if (idcode.eq.1) go to 3 ! "t" + tie = .false. + go to 5 +2 continue + end if + go to 1 +3 continue + tie = .true. +5 continue +c +c A slur or tie is open, with index ndx +c + iv = igetbits(isdat1(isdat),5,13) + kv = igetbits(isdat1(isdat),1,12)+1 + udq = 'd' + if (btest(isdat1(isdat),27)) udq='u' + notexq = chax(92)//'znotes' + lnote = 7 + do 4 iiv = 1 , iv-1 + notexq = notexq(1:lnote)//sepsymq(iiv) + lnote = lnote+1 +4 continue + if (kv .eq. 2) then + notexq = notexq(1:lnote)//chax(92)//'nextvoice' + lnote = lnote+10 + end if +c +c Compute horiz and vert offsets +c +c nolev = igetbits(isdat2(isdat),7,19) + islhgt = igetbits(isdat3(isdat),8,14) + ilb12 = 0 + if (ispstie) ilb12 = 1 + ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32 + if (ivoff .eq. -32) ivoff = 0 +C nolev = nolev+ivoff + islhgt = islhgt+ivoff + ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff + if (ihoff .eq. -64) ihoff = 0 +c +c Add starting stuff for command +c + if (.not.ispstie) then ! End 1st segment + notexq = notexq(1:lnote)//chax(92)//'roffset{' + lnote = lnote+9 +c hoff = ihoff*.1-.5 +c hoff = ihoff*.1-.8 + hoff = ihoff*.1-.4 + if (hoff .lt. 0) then + hoff = -hoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(hoff,notexq,lnote) + notexq = notexq(1:lnote)//'}{' + lnote = lnote+2 + else + notexq = notexq(1:lnote)//chax(92)//'off{-' + * //chax(92)//'afterruleskip}' + lnote = lnote+21 +c +c 091025 add dotting for 2nd segment if needed +c + if (btest(isdat2(isdat),4)) then + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if + end if + if (ispstie .and. tie) then + notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq + lnote = lnote+10 + end if + if (btest(isdat3(isdat),0)) then +c +c Curvature tweak on termination of 1st seg +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: +c Abs(imid) Postscript slur type +c 1 f +c 4 h +c 5 H +c 6 HH +c + notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid) + lnote = lnote+9 +c +c Zero out the flag in case there's a different curv on term of 2nd, +c + isdat3(isdat) = ibclr(isdat3(isdat),0) + end if +c +c Add the command name +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'is'//udq + lnote = lnote+4 + else if (tie) then + notexq = notexq(1:lnote)//chax(92)//'ttie' + lnote = lnote+5 + else + notexq = notexq(1:lnote)//chax(92)//'tslur' + lnote = lnote+6 + end if +c +c Add index +c +c if (11-ndx .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndx) +c lnote = lnote+1 +c else +c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' +c lnote = lnote+4 +c end if + if (23-ndx .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndx) + lnote = lnote+1 + else if (23-ndx .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}' + lnote = lnote+4 + end if + if (ispstie .or. .not.tie) then +c +c Add note name for slur height +c + noctup = 0 + ncm = igetbits(isdat3(isdat),8,22) + if (ncm .eq. 23) noctup = -2 +c call notefq(noteq,lnoten,nolev,ncm) + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}' + lnote = lnote+1+lnoten+1 + end if + if (ispstie) then +c +c Horizontal shift start of new thing +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 +c ihoff = ihoff-13 + if (tie) then + ihoff = ihoff-12 + else + ihoff = ihoff-7 + end if + if (ihoff .lt. 0) then + ihoff = -ihoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(ihoff*.1,notexq,lnote) + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Add closing stuff +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'off{' + * //chax(92)//'afterruleskip}' + lnote = lnote+20 + else + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//chax(92)//'en%' + lnote = lnote+4 + write(11,'(a)')notexq(1:lnote) +1 continue + ispstie = .not.ispstie + return + end + subroutine littex(islur,nnl,iv,topmods,lineq,iccount) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + integer islur(nm,200) + logical topmods + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,merge + character*128 lineq,litq + character*20 voltxtq + character*1 durq,chax + merge = .false. + if (nlit .gt. 0) then + merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit) + end if + nlit = nlit+1 + ivlit(nlit) = iv + iplit(nlit) = nnl + itype = 1 +17 call getchar(lineq,iccount,durq) + if (durq .eq. chax(92)) then + itype=itype+1 + go to 17 + end if + litq(nlit) = chax(92)//durq + lenlit(nlit) = 2 +18 call getchar(lineq,iccount,durq) + if (durq.eq.chax(92)) then + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Starting a new tex command within the string +c + litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq + lenlit(nlit) = lenlit(nlit)+2 + go to 18 + end if + else + litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq + lenlit(nlit) = lenlit(nlit)+1 + go to 18 + end if +c +c If here, just read backslash-blank so string is done +c + if (itype .eq. 1) then + islur(iv,nnl) = ibset(islur(iv,nnl),16) + if (merge) then +c +c There are 2 separate strings on the same note, so merge them. +c + nlit = nlit-1 + litq(nlit) = litq(nlit)(1:lenlit(nlit)) + * //litq(nlit+1)(1:lenlit(nlit+1)) + lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1) + if (lenlit(nlit) .gt. 128) then + print* + print*, + * 'Merged type-1 TeX strings longer than 128 characters' + write(15,'(/,a)') + * 'Merged type-1 TeX strings longer than 128 characters' + call stop1() + end if + end if + else + if (itype .eq. 3) then +c +c Write the string NOW +c + if (islast) + * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + else +c +c Must go at top +c + if (.not.topmods) then + topmods = .true. + open(16,status='SCRATCH') + end if +c +c Must write '%' here rather than later, in case string ends with blank. +c + write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + end if + nlit = nlit-1 + end if + return + end + function llen(strq,n) + character*129 strq + do 1 llen = n , 0 , -1 + if (strq(llen:llen) .ne. ' ') return +1 continue + end + function log2(n) +c +c 5/25/08 Modify to allow more slurs +c +c log2 = alog(1.*n)/0.6931472+.0001 +c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 + log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0 + return + end + subroutine logbeam(numnew,nip1,nip2) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq,ulfq,ulfbq + logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest, + * autofbon + ibm1(ivx,numnew) = nip1 + ibm2(ivx,numnew) = nip2 + numnow = numnew + if (numnew .gt. 1) then +c +c If it starts before any others, must put it in order +c + do 11 ib = numnew-1 , 1 , -1 + if (ibm1(ivx,ib) .lt. nip1) go to 12 + ibm1(ivx,ib+1) = ibm1(ivx,ib) + ibm2(ivx,ib+1) = ibm2(ivx,ib) + ulq(ivx,ib+1) = ulq(ivx,ib) + ibm1(ivx,ib) = nip1 + ibm2(ivx,ib) = nip2 + numnow = ib +11 continue +12 continue + end if + sum = 0. +c +c Beam has non-xtup within +c + nrests = 0 + isxtup = .false. + do 9 iip = nip1 , nip2 + if (btest(islur(ivx,nip1),21)) then +c +c Forced multiplicity +c +c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) + call setbits(mult(ivx,iip),4,0, + * igetbits(islur(ivx,nip1),3,22)+8) + else if (.not.isxtup) then + if (nodur(ivx,iip) .gt. 0) then +c mult(ivx,iip) = 4-log2(nodur(ivx,iip)) + call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8) + else +c +c Start xtup within forced beam +c + isxtup = .true. + iip1 = iip + end if + else if (isxtup .and. nodur(ivx,iip).gt.0) then +c +c End of xtup within forced beam. Must count doubled notes +c + ndoub = 0 + do 1 iiip = iip1 , iip + if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1 +1 continue + multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)- + * alog(nodur(ivx,iip)/2.))/0.69315)-10 + do 74 iiip = iip1 , iip +c mult(ivx,iiip) = multx + call setbits(mult(ivx,iiip),4,0,multx+8) +c +c Note the following still works after making mult only the 1st 4 bits. +c + if (btest(nacc(ivx,iiip),18)) + * mult(ivx,iiip) = mult(ivx,iiip)-1 + if (btest(nacc(ivx,iiip),19)) then + mult(ivx,iiip) = mult(ivx,iiip)+1 + else if (iiip .gt. 1) then + if (btest(nacc(ivx,iiip-1),19)) + * mult(ivx,iiip) = mult(ivx,iiip)+1 + end if +74 continue + isxtup = .false. + end if + if (btest(irest(ivx,iip),0)) then + nrests = nrests+1 + else + sum = sum+nolev(ivx,iip) + end if +9 continue +c +c Set beam up-down-ness +c + if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then + if (ulfbq(ivx,ifb) .eq. 'f') then +c +c Get default, then trade "l" and "u" +c + ulq(ivx,numnow) = char(225-ichar( + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)))) + else + ulq(ivx,ifb) = ulfbq(ivx,ifb) + end if +c +c This probably works only because forced beams are done first, so they +c don't have to be re-sorted within each voice. ???? +c + else if (nvmx(iv) .eq. 2) then +c +c Multi-voice per staff +c + if (ivx .le. nv) then + ulq(ivx,numnow) = 'l' + else + ulq(ivx,numnow) = 'u' + end if + else +c +c Defaults +c + ulq(ivx,numnow) = + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)) + end if + return + end + subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + logical mrecord,mplay,endmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lbuf(1) = lbuf(1) + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then + call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1, + * 'Improper macro termination!') + call stop1() + end if + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + parameter (nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst + common /comeskz2/ eskz2(nm,200) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm), + * numbms(nm),mapfb(16) + real*4 xit(nm),t1xtup(20),tstart(80),squez(80) + character*1 ulfbq + character*79 inameq + character*20 voltxtq + common /comoct/ noctup + character*80 headrq,lowerq + logical cwrferm + common /comcwrf/ cwrferm(nm) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical lower,cwrest(nm),vxtup,flgndb,btest,upslur, + * infbmx(nm),lowdot,inxtup(nm),drawbm + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Above are factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur, + * WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comntot/ ntot + if (ismidi) then +c +c Initialize for this bar the accidental counter for the midi file. +c naccim(icm) = # of accidentals from earlier in the bar +c + do 45 iv = 1 , nv + do 45 kv = 1 , nvmx(iv) + naccim(midchan(iv,kv)) = 0 +45 continue + end if +c +c Time from start of gulp to end of bar, used with forced beams +c + tglp2 = lenb0+ibar*lenb1 + if (lenb0 .gt. 0) tglp2 = tglp2-lenb1 + tglp1 = tglp2-lenbar +c +c infbmx will only be true if in xtup that is NOT in explicit forced beam. +c + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrest(ivx) = .false. + infbmx(ivx) = .false. + inxtup(ivx) = .false. + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv). The loop to 4 +c ONLY initializes each voice. +c + in = 1 + nxtup = 0 + narp = 0 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrferm(ivx) = .false. + cnn(ivx) = 1 + ivxo(in) = ivx + ipo(in) = cnn(ivx) + tnote(in) = fnote(nodur,ivx,1,nacc) + to(in) = 0. + xit(ivx) = tnote(in) +c +c Note that xit(ivx) is to END of note in voice, but it1xtup is start time. +c + if (nodur(ivx,ipo(in)) .eq. 0) then +c +c First note of xtuplet at start of bar in voice ivx. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = 0. +c +c Xtup at start of bar. If no explicit forced beam, start one, set +c signal infbmx, and save number ifbnow for use at termination. +c + if (nfb(ivx) .gt. 0) then + do 60 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c No explicit fb here; so exit loop and insert one. +c + go to 61 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit fb here; must NOT insert one +c + go to 62 + end if +60 continue + end if +61 continue +c +c If here, xtup isn't in explicit fb, so must insert one +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+ + * tglp1,t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +62 continue + if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000. + in = in+1 +4 continue +c +c Build the list: This is a manual loop starting at 5 +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iiv = 1 , nv + do 6 kv = 1 , nvmx(iiv) + iivx = ivmx(iiv,kv) + tminn = min(tmin,xit(iivx)) + if(tminn .lt. tmin-tol) then + tmin = tminn + ivx = iivx + end if +6 continue + if (abs(tmin-1000.) .lt. tol) go to 7 + ivxo(in) = ivx + cnn(ivx) = cnn(ivx)+1 + ipo(in) = cnn(ivx) + to(in) = tmin +c +c Check if this voice is done +c + tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc) + if (cnn(ivx) .eq. nn(ivx)) then + xit(ivx) = 1000. + else + xit(ivx) = xit(ivx)+tnote(in) + end if +c +c Flag xtups +c + if (nodur(ivx,cnn(ivx)) .eq. 0) then + if (.not.inxtup(ivx)) then +c +c First note of xtup, not at start of bar. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = xit(ivx)-tnote(in) +c +c (Note: can't be on last note in voice, so xit(ivx) <> 1000) +c Put xtuplet in a forced beam if not already in forced beam +c + if (nfb(ivx) .gt. 0) then + do 70 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c NO explicit bm; put one in +c + go to 71 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit bm. Don't put one +c + go to 72 + end if +70 continue + end if +71 continue +c +c If here, no explicit bm, so put one in +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+tglp1, + * t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +72 continue + else if (inxtup(ivx)) then +c +c This test is sufficient because already know nodur>0 +c + inxtup(ivx) = .false. + if (infbmx(ivx)) then +c +c Xtup is in auto-forced beam, so end it +c + t2fb(ivx,ifbnow(ivx)) = + * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1 + infbmx(ivx) = .false. + end if + end if + if (btest(irest(ivxo(in),ipo(in)),24) .or. + * btest(irest(ivxo(in),ipo(in)),30)) then +c +c For staff jumped beam, flag the first note (lowest voice) at same time. +c Later will start new notes group here. +c + inj = in + if (ivxo(in) .gt. 1) then + do 40 iin = in-1 , 1 , -1 + if (to(iin)+tol .lt. to(in)) go to 41 + if (abs(to(iin)-to(in)) .lt. tol) then + inj = iin + go to 40 + end if +40 continue + end if +41 continue + irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29) + end if + in = in+1 + go to 5 +7 continue + ntot = in-1 + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = tnote(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(a)')' Greetings from PMXB' +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +c +c Done w/ list. Loop for parsing into note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c A manual loop to set space(ib) and istop(ib) +c +9 continue + + ivx = ivxo(min(in+1,ntot)) + ip = ipo(min(in+1,ntot)) + isl = islur(ivx,ip) + if (in.eq.ntot .or. ((ivx.eq.1 .and. + * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28) +c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then +c Bits 1-13: stmgx+Tupf._) +c 14: Down fermata, was F +c 15: Trill w/o "tr", was U + * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) ) +c +c Checking for start of 2nd part of jumped beam +c + * .or. btest(irest(ivx,ip),29) ) then +c +c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; +c flow out of if-loop and into block-wrapup +c +c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered +c voice, but it wasn't first in the list at the same time. So check if +c prior notes in list have same time +c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef +c changes on last note in the list? +c + if (btest(isl,15) .and. in.lt.ntot) then + do 50 iin = in , 1 , -1 + if (tno(iin) .gt. tol) then + in = iin + islur(ivx,ip) = ibclr(islur(ivx,ip),15) + islur(ivxo(in+1),ipo(in+1)) = + * ibset(islur(ivxo(in+1),ipo(in+1)),15) + go to 51 + end if +50 continue +51 continue + end if + if (space(ib) .lt. tol) then + space(ib) = tno(in) + squez(ib) = 1. + end if + istop(ib) = in + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the group, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart and istop are good, so finalize block +c + tstart(ib) = to(istart(ib)) + if (istop(ib) .eq. ntot) go to 15 + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space and squeeze-factor for upcoming block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue + nb = ib +c +c Invert the list of places into ipl(0-7), making it easier to analyze a voice +c + do 13 in = 1 , ntot +c +c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. +c +c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) + ipl2(ivxo(in),ipo(in)) = in +13 continue +c +c Compute elemskips from start of bar to each note in the bar, for beam slopes +c + eskzb = 0. + ib = 1 + do 30 in = 1 , ntot + if (in .eq. istart(ib)) then + deskb = squez(ib)*feon(space(ib)/squez(ib)) + else if (tno(in-1) .gt. tol) then + eskzb = eskzb+deskb + end if + eskz(ivxo(in),ipo(in)) = eskzb + eskz2(ivxo(in),ipo(in)) = eskzb + if (in .eq. istop(ib)) then + eskzb = eskzb+deskb + ib = ib+1 + end if +30 continue +c +c Debug writes +c +c print* +c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) +c print*,'PMXB has now got blocks' +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, +c * in=1,ntot) +c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) +c +c +c Analyze for beams. +c + do 20 iv = 1 , nv + do 20 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + numbms(ivx) = 0 + mapfb(1) = 0 + mapfb(2) = 0 + mapfb(3) = 0 + mapfb(4) = 0 +c +c First forced beams. +c + if (nfb(ivx) .gt. 0) then +c +c tglp2 is time from start of gulp to end of current bar. +c + nfbbar = 0 + do 80 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81 + nfbbar = nfbbar+1 + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) +c +c Times from beginning of bar +c + itbb1 = int(t1fb(ivx,ifb)-tglp1+tol) + itbb2 = int(t2fb(ivx,ifb)-tglp1+tol) + do 83 ip = 1 , nn(ivx) + if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then + nip1fb = ip + do 84 ip1 = ip , nn(ivx) + inip1 = ipl2(ivx,ip1) + if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then + nip2fb = ip1 + itbb3 = itbb2-2 + go to 85 + end if +84 continue + end if +83 continue + print* + print*,'Timing problem w/ forced beams' + write(15,'(/a)')'Timing problem w/ forced beams' +85 continue + call logbeam(numnew,nip1fb,nip2fb) +c +c Set up mapfb for forced beam just logged: +c + ib1 = itbb1/2 + ib2 = itbb3/2 + ibrep = lenbar/ibmrep/2 + do 86 irep = 1 , ibmrep + ib1now = max(0,ib1-(irep-1)*ibrep) + ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep) + mapnow = 0 + do 87 ib = ib1now , ib2now + mapnow = ibset(mapnow,ib) +87 continue + mapfb(irep) = ior(mapfb(irep),mapnow) +86 continue +c +c Since we are cycling thru forced beams, for those that start with a rest and +c have height & slope adjustments, move adjustments to next note. +c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at +c start of beam +c + if (btest(irest(ivx,nip1fb),0)) then +c call setbits(ipl(ivx,nip1fb+1),6,11, +c * igetbits(ipl(ivx,nip1fb),6,11)) +c call setbits(ipl(ivx,nip1fb+1),6,17, +c * igetbits(ipl(ivx,nip1fb),6,17)) +c call setbits(islur(ivx,nip1fb+1),2,27, +c * igetbits(islur(ivx,nip1fb),2,27)) + do 88 kp = nip1fb+1 , nip2fb + call setbits(ipl(ivx,kp),6,11, + * igetbits(ipl(ivx,nip1fb),6,11)) + call setbits(ipl(ivx,kp),6,17, + * igetbits(ipl(ivx,nip1fb),6,17)) + call setbits(islur(ivx,kp),2,27, + * igetbits(islur(ivx,nip1fb),2,27)) +88 continue + end if +80 continue +81 continue +c +c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. +c Remember, makeabar is called 1/bar, and it calls findbeam once per voice. +c + if (nfbbar .gt. 0) then + nfb(ivx) = nfb(ivx)-nfbbar + do 82 ifb = 1 , nfb(ivx) + t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar) + t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar) + ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar) +82 continue + end if + end if + ifb = 0 +c +c Done with forced beam masks for this bar and voice. Now get normal beams. +c + call findbeam(ibmrep,numbms,mapfb) +20 continue + return + end + subroutine make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp, + * isbj2 + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,issig,rpndot,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer istart(80),istop(80),iaskb(nm),numbms(nm), + * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2) + character*1 ulfbq,udqq,clefq(nm),slurudq + character*8 noteq + character*79 cwrq(nm),notexq,inameq + character*20 voltxtq + common /comoct/ noctup + character*80 soutq,headrq,lowerq + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical bspend,lower,cwrest(nm),vxtup, + * isgrace,isclef,nofirst,iscln,isdot,isflag, + * isacc,isfirst,flgndb,btest,stemup,upslur, + * isgaft,isarp,isrshft,isaccs,iscacc, + * lowdot,flipend,iscwr,isdotted,beamon1(nm) + real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80), + * squez(80) + logical cwrferm,drawbm + common /comcwrf/ cwrferm(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur + * ,WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + logical secondgrace +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c Set up main ib loop within which a block (notes group) is written +c + do 25 iv = 1 , nv + do 25 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ibmcnt(ivx) = 1 + ibmcnt1(ivx) = 1 + beamon(ivx) = .false. + beamon1(ivx) = .false. + nornb(ivx) = 0 + iaskb(ivx) = 1 + vxtup(ivx) = .false. + drawbm(ivx) = .true. +25 continue + naskb = 0 + ifig(1) = 1 + ifig(2) = 1 + ixtup = 0 + bspend = .false. + iscwr = .false. + rpndot = .false. + do 16 ib = 1 , nb +c +c Check for segno +c + if (btest(iornq(1,ipo(istart(ib))),4) .and. + * ivxo(istart(ib)).eq.1) then + if (noffseg.le.-10) then + write(noteq(1:5),'(1H{,i3,1H})')noffseg + lnoten = 5 + else if (noffseg.lt.0 .or. noffseg.ge.10) then + write(noteq(1:4),'(1H{,i2,1H})')noffseg + lnoten = 4 + else + write(noteq(1:1),'(i1)')noffseg + lnoten = 1 + end if + notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9' + lnote = 15+lnoten + do 130 iv = 2 , nv + if (lnote .gt. 60) then + if (islast) write(11,'(a)')notexq(1:lnote)//'%' + notexq = sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnoten+9 + else + notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnote+lnoten+9 + end if +130 continue + if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en' + lnote = 0 + end if +c +c Check for new clefs +c + isclef = .false. + if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15)) + * then +c +c In preceding line, fl32 gave wrong result for ... .gt.0 !!! +c + do 140 in = istart(ib) , istop(ib) + if (btest(islur(ivxo(in),ipo(in)),11)) then + call wsclef(ivxo(in),ninow,clefq, + * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) + end if +140 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + isclef = .true. + end if +c +c Start a notes group. We're just gonna define every one using pnotes{n}, +c where \def\pnotes#1{\vnotes#1\elemskip} +c + soutq = sq//'pnotes{' + eonsqz = squez(ib)*feon(space(ib)/squez(ib)) + if (eonsqz .gt. 9.995) then + write(soutq(9:12),'(f4.1)')eonsqz + else if (eonsqz .gt. 0.995) then + write(soutq(9:12),'(f4.2)')eonsqz + else if (eonsqz .gt. 0.095) then + soutq = soutq(1:8)//'0.' + write(soutq(11:12),'(i2)')nint(100*eonsqz) + else + soutq = soutq(1:8)//'0.0' + write(soutq(12:12),'(i1)')nint(100*eonsqz) + end if + soutq = soutq(1:12)//'}' + lsout = 13 +c +c Check whole block, flag accidentals etc that are too close, one per *time*. +c Note about bar starts and after rpt's/boublebars: There is an afterruleskip +c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so +c (dotsfac*wheadpt) is presumed to be filled up. +c + in = istart(ib)-1 + itrpt = -1 + itsig = -1 +c +c Begin big manual loop over notes in this block; ends at 112 +c +111 in = in+1 + if (in .gt. istop(ib)) go to 112 + ip = ipo(in) + ivx = ivxo(in) + if (ivx .le. nv) then + iv = ivx + else + do 128 iv = 1 , nv + if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129 +128 continue + print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2) + print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2) + stop + end if +129 continue +c +c Call precrd here so we know how much space to add for accid's in chords +c After calling precrd, icashft>0 means there is a shifted chordal accid (incl. +c main note. +c +c To call precrd, need up-downness, so must track if in beam. +c +c Deal w/ staff-jumping beams later +c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. +c * btest(nacc(ivx,ip),21)) then +c if (.not.btest(irest(ivx,ip),24)) then + if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx) + * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then + beamon1(ivx)=.true. + end if + icashft = 0 + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. +c + if (beamon1(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)), + * .false.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .false.,icashft) + end if + end if +c +c Turn beam off? +c + if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then + beamon1(ivx) = .false. + ibmcnt1(ivx) = ibmcnt1(ivx)+1 + end if +c +c Remember, rpts & internal sigs can only come at start of (internal) block +c + isacc = iand(nacc(ivx,ip),3).gt.0 + * .and. .not.btest(nacc(ivx,ip),17) + * .and. .not.btest(ipl(ivx,ip),10) +c +c i.e., do not set for chord. Now check for "(" as ornament on main note, +c +c!!! Need to do this for chord notes too. Maybe in chkarp? +c + isaccs = isacc .or. btest(iornq(ivx,ip),0) +c +c 5/15/02 Add check for ) ornament of prior note. +c 5/16 Nope...fails when grace intervenes. +c if (ip .gt. 1) then +c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) +c end if + isarp = btest(iornq(ivx,ip),27) + iscacc = .false. + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord here; check for arpeggios and accidentals. Note accid shifts are +c not of concern here, only whether there's an accid, whick causes iscacc=.true. +c + iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and. + * .not.btest(nacc(ivx,ip),17) + call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) + end if +c +c When we get motivated, will do spacing for arpeggios here. +c + if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) + * itrpt = nint(to(in)) + issig = btest(ipl(ivx,ip),28) + if (ivx.eq.1 .and. issig) itsig = nint(to(in)) + isgrace = btest(islur(ivx,ip),4) .and. + * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31) + isgaft = .false. + if (ip .gt. 1) then + xnd = tnote(ipl2(ivx,ip-1)) + isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31) + isgrace = isgrace .or. isgaft + end if + iscln = isclef .and. btest(islur(ivx,ip),11) +c +c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd +c + isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol + if (isflag) + * isflag = .not.btest(irest(ivx,ip-1),0) + * .and. udqq(nolev(ivx,ip-1), + * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u' + if (isflag) then + do 116 ibmchk = 1 , numbms(ivx) + if (ip-1 .lt. ibm1(ivx,ibmchk)) then + go to 117 +c +c Add check for non-beamed xtuplets. May be problem with stem direction. +c +c else if (ip-1.le.ibm2(ivx,ibmchk)) then + else if (ip-1.le.ibm2(ivx,ibmchk) .and. + * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then + isflag = .false. + go to 117 + end if +116 continue + end if +117 continue +c +c If isflag, then won't need to check for dot on prev. note. +c +c 5/16/02 ??? Try using this for ) ornament. +c + isflag = isflag .or. btest(iornq(ivx,ip-1),13) + isdot = ip.gt.1 + if (isdot) isdot = isdotted(nodur,ivx,ip-1) + isrshft = ip .gt. 1 + if (isrshft) isrshft = btest(irest(ivx,ip-1),20) + if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or. + * isdot.or.btest(iornq(ivx,ip),26).or. + * btest(irest(ivx,ip),21).or.isarp.or. + * btest(irest(ivx,ip),27).or.iscacc)) go to 111 +c +c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. +c Compute pts, the total occupied space including prior notehead. +c + wheadpt1 = wheadpt*fullsize(iv) + pts = wheadpt1 +c +c Set up for possible cautionary accidental here +c + if (isaccs .or. iscacc) then + if (.not.btest(iornq(ivx,ip),31)) then + taccfac = accfac + else + taccfac = 1.4*accfac + end if + end if + if (isgrace) then + secondgrace = .false. + do 122 ig = 1 , ngrace + if (.not. isgaft) then + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123 + else if (ip .gt. 1) then + if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123 + end if +122 continue + print*,'Problem finding grace index in makeabar' + stop +123 continue +c +c wgr = distance to backspace (in headwidths), less main acc. +c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. +c spgr = total space needed (w/o main acc). +c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. +c + if (nng(ig) .eq. 1) then + wgr = grafac + if (multg(ig) .eq. 0) wgr = wgr-.4 + else + wgr = nng(ig)*emgfac + do 126 ing = 2 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +126 continue + end if + if (graspace(ig) .gt. 0.) then +c +c User-defined space before grace +c + wgr = wgr+graspace(ig) + end if + ptgr(ig) = wgr*wheadpt1 + spgr = ptgr(ig)+xb4fac*wheadpt1 +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1 + if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac + pts = pts+spgr +c +c Special check for after-grace on ip-1 and normal on ip. Must go back thru +c loop again for the normal grace. +c + if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then + if (ipg(ig+1).eq.ip) then + secondgrace = .true. + ig = ig+1 + go to 123 + end if + end if + end if + if (iscln) then + pts = pts+clefac*wheadpt1 +c +c How far to backspace when printing the clef +c + ptclef(ivx) = 0. +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) + * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1 + if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr + end if + if (isrshft) then + pts = pts+rtshfac*wheadpt1 + else if (isflag) then + pts = pts+flagfac*wheadpt1 + else if (isdot) then + pts = pts+dotfac*wheadpt1 + end if + if (abs(to(in)-itrpt) .lt. tol) then +c +c Repeat, need a little extra space +c + pts = pts+dotsfac*wheadpt1 + end if + if (isarp) then + pts = pts+arpfac*wheadpt1 + end if +c +c Add in padding space +c + pts = pts+xspfac*wheadpt1 +c +c Now done with all items needing space except accidentals, +c accidental shifts, and left-notehead-shifts, and will later +c subtract a notehead if at start of bar. +c +c Get available space in elemskips (esk) +c +c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. +c * to(in) .eq. itsig + isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or. + * abs(to(in)-itsig).lt.tol + if (isfirst) then +c +c At start of bar or after repeat sign or new signature +c +c if (to(in) .eq. itsig) then + if (abs(to(in)-itsig).lt.tol) then + esk = 0. + else + esk = fbar + end if + else +c +c Not 1st note of bar +c + esk = eskz(ivx,ip)-eskz(ivx,ip-1) + end if + if (isgrace) then +c +c Since graces can be very long, cannot assume no interference if prior +c note uses >1 noteskip. So must get elsk's back to prior note, whether or +c not it used only one noteskip. +c <>???? +c +c 10/8/05 Kluge to not zero out esk if in xtup +c + esksav = esk + if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and. +c * to(in).ne.itsig) + * abs(to(in)-itsig).gt.tol) + * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) + if (abs(esk) .lt. tol) esk = esksav + end if +c +c Done getting available elemskips. Remove headwidth if first. Must do here +c rather than earlier since check uses isfirst +c + if (isfirst) pts = pts-wheadpt1 +c +c Deal with accidental shifts and left-notehead shifts +c + if (btest(ipl(ivx,ip),10)) then +c +c In a chord +c + ptsl = 0. + if (btest(irest(ivx,ip),27)) ptsl = wheadpt1 + ptsadd = max(ptsl,icashft*.05*wheadpt1) +c +c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK +c + else +c +c Not in a chord +c + ihshft = 0 + if (isaccs) then + ihshft = igetbits(nacc(ivx,ip),7,10) +c if (ihshft .ne. 0) ihshft = max(0,64-ihshft) + if (ihshft .ne. 0) ihshft = max(0,107-ihshft) + end if +c +c Check for left-shifted main note +c + if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft) + ptsadd = ihshft*.05*wheadpt1 + end if + pts = pts+ptsadd + if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd + if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd +c +c Left-shifted, non-chord note before? +c + if (ip .gt. 1) then + if (.not.btest(ipl(ivx,ip-1),10) .and. + * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1 + end if +c +c Try big accidentals first +c + ptbneed = pts + if (isaccs .or. iscacc) then + ptbneed = ptbneed+wheadpt1*bacfac + end if + if (poenom*esk .gt. ptbneed) then +c +c Set flag for big accidental +c + if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3) + go to 99 + end if +c +c Cannot use big, so try small +c + ptsneed = pts + if (isaccs .or. iscacc) then + ptsneed = ptsneed+taccfac*wheadpt1 + end if + if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, + * esk,fixednew,scaldold,0.,.false.) +99 continue + if (btest(iornq(ivx,ip),26)) then +c +c User-defined space. Warning, "zero" may change value in addask! +c + zero = 0. + call addask(to(in),ptsneed,zero, + * fixednew,scaldold,tglp1,.true.) + end if +c +c End of big manual loop over "in" for accidental checking +c + go to 111 +112 continue +c +c End of ask analysis for this block. +c +c Adjust eskz if there are added spaces. Corrects length of xtup brackets. +c + if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom) +c +c Check for internal repeat or sig change. +c + if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then + iirpt = iand(islur(1,ipo(istart(ib))),67109216) + if (iirpt .gt. 0) then +c +c Internal repeat +c + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (iirpt .eq. 96) then + if (islast) write(11,'(a)')sq//'leftrightrepeat' + fixednew = fixednew+lrrptfac*wheadpt + else if (btest(iirpt,5)) then + if (islast) write(11,'(a)')sq//'leftrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,6)) then + if (islast) write(11,'(a)')sq//'rightrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,8)) then + if (islast) write(11,'(a)')sq//'doublebar' + else + print*,'Unexpected mid-bar repeat command R*' + call stop1() + end if + scaldold = scaldold-fbar + end if + if (btest(ipl(1,ipo(istart(ib))),28)) then +c +c Internal signature change. +c + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'//sq//'afterruleskip}%' + lnote = 0 + end if + end if + flgndb = .false. +c +c Done with start-of-block stuff. Begin main loop over voices. +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + icm = midchan(iv,kv) +c +c A rather klugey way to set flag for figure in this voice +c Must always check figbass before figchk. +c + if (figbass) then + ivf = 0 + if (ivx .eq. 1) then + ivf = 1 + else if (ivx .eq. ivxfig2) then + ivf = 2 + end if + if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0 + end if + if (ivx .gt. 1) then + if (ivx .le. nv) then + call addstr(sepsymq(iv-1),1,soutq,lsout) + else + call addstr(sq//'nextvoice',10,soutq,lsout) + end if + end if + if (ihdht.gt.0 .and. ivx.eq.nv) then +c +c Write header. First adjust height if needed to miss barno. +c + if (bar1syst .and. iline.ne.1) then + ihdht = 15+irzbnd+isnx + end if +c +c Add user-defined vertical shift +c + ihdht = ihdht+ihdvrt + lchead = lenstr(headrq,80) + notexq = sq//'zcharnote{' + write(notexq(12:13),'(i2)')ihdht + notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt ' + call addstr(notexq,34,soutq,lsout) + call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout) + ihdht = 0 + end if + if (lower .and. ivx.eq.nv) then + lclow = lenstr(lowerq,80) + call addstr(sq//'zcharnote{-6}{'// + * sq//'tempo'//sq//'kern-10pt '// + * lowerq(1:lclow)//'}',33+lclow,soutq,lsout) + lower=.false. + end if + tnow = tstart(ib) + nofirst = .true. +c +c Done setting up voice ivx for start of block ib. Loop over notes in voice. +c + do 10 jn = istart(ib), istop(ib) + if (ivxo(jn) .ne. ivx) go to 10 + ip = ipo(jn) +c +c May have problem with not initializing islhgt, so do it here +c + islhgt = 0 +c + if (nofirst) then + noctup = 0 + if (ncmid(iv,ip) .eq. 23) noctup = -2 + nofirst = .false. + end if +c +c Check for internal floating figure (before last note of group). +c +12 if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol) + * then +c +c Bypassed figure location. Backup, place fig, return. +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq, + * lsout) + go to 12 + end if + end if + end if +c +c Put in \sk if needed +c + if (to(jn) .gt. tnow+tol) then + call addstr(sq//'sk',3,soutq,lsout) + tnow = tnow+space(ib) + go to 12 + end if +c +c Check for user-defined shifts +c + if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16)) + * call putshft(ivx,.true.,soutq,lsout) +21 if (iaskb(ivx).le.naskb .and. + * tnow.gt.task(iaskb(ivx))-tol) then + if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then +c +c Insert placeholder for accidental skip +c + call addstr(sq//'ask ',9,soutq,lsout) + nasksys = nasksys+1 + wasksys(nasksys) = wask(iaskb(ivx)) + if (wask(iaskb(ivx)) .gt. 0.) then + elasksys(nasksys) = elask(iaskb(ivx)) + else +c +c This is a signal to permit negative ask's. Should really have elask>=0. +c + elasksys(nasksys) = -elask(iaskb(ivx)) + end if + end if +c +c May have skipped some task's in earlier blocks (due to void voice) +c + iaskb(ivx) = iaskb(ivx)+1 + go to 21 + end if + if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. + * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then +c +c Figure on a note. NB: later special check for late figs. +c + call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout) + end if + end if + end if +c +c Check for new clef here. +c + if (isclef .and. btest(islur(ivx,ip),11)) then +c print*,'At clef insertion, ptclef:',ptclef(iv) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{-' + if (ptclef(iv) .lt. 9.95) then + write(notexq(7:9),'(f3.1)')ptclef(iv) + lnote = 9 + else + write(notexq(7:10),'(f4.1)')ptclef(iv) + lnote = 10 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) +c print*,'Just added: ',notexq(1:lnote) + end if + call clefsym(islur(iv,ip),notexq,lnote,nclef) + call addstr(notexq,lnote,soutq,lsout) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{' + if (ptclef(iv) .lt. 9.95) then + write(notexq(6:8),'(f3.1)')ptclef(iv) + lnote = 8 + else + write(notexq(6:9),'(f4.1)')ptclef(iv) + lnote = 9 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) + end if + end if +c +c Checking for literal TeX string BEFORE starting beams!! +c + if (btest(islur(ivx,ip),16)) then + do 124 il = 1 , nlit + if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125 +124 continue + print*,'Problem finding index for literal string' + call stop1() +125 continue +c +c Write a type 1 tex string. +c + if (lenlit(il) .lt. 71) then +c +c Add normally +c + call addstr(litq(il),lenlit(il),soutq,lsout) + else +c +c Longer than 71. Write souq, Write string, start new soutq. +c + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%' + lsout = 0 + end if + end if +c +c Arpeggio on a main (non-chordal) note? +c + if (btest(iornq(ivx,ip),27)) then +c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), + call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip), + * soutq,lsout) + end if +c +c See if a beam starts here +c + 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 +c +c Not a jump start +c + call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) +c +c Shift beam start if notehead was shifted +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) + else +c +c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set +c to 0 at end of first part of jump beam +c + ivbj2 = ivx +c +c Check for xtup since we bypassed beamstrt wherein vxtup is normally set +c + if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2) + * vxtup(ivx) = .true. +c +c Since beamstrt is not called, and drawbm is normally set there, need to set +c it here. This could cause problems if someone tries a staff-jumping, +c unbarred beam, which I'll deal with when it comes up. +c + drawbm(ivx) = .true. + end if + if (ixrest(ivx) .eq. 0) then + beamon(ivx) = .true. + bspend = .true. + if (.not.btest(irest(ivx,ip),24))bspend = .true. + end if + end if +c +c Setup for chords and possible slurs in chords +c + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Just rerun precrd. Klunky, but saves +c me from tracking down errors instroduced when I moved 1st call +c forward for accidental spacing analysis. +c + if (beamon(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)), + * .true.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .true.,icashft) + end if + end if +c +c Is there slur or grace activity? +c + isgrace = btest(islur(ivx,ip),4) + if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31) +c +c isgrace if not 1st note in bar and previous note has Way-after grace. +c + if (btest(islur(ivx,ip),0) .or. isgrace) then + if (btest(islur(ivx,ip),0)) then + if (fontslur) then +c +c Call routine for non-postscript slurs +c + call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + else +c +c Postscript slurs +c + call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3, + * isdat4,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + end if + end if + if (isgrace) then +c +c Grace note. +c + iphold = ip + isgrace = .false. + if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31) + if (isgrace) iphold = iphold-1 + isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31) + * .and..not.btest(ipl(ivx,ip),29)) +c +c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace +c on current note. Do A-grace on current note, and W-grace at barend, later. +c + if (isgrace) then + call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,iphold),.false., + * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx), + * tnote(ipl2(ivx,ip)),ulq) + if (slurg(ig)) then +c +c Terminate slur started in dograce. Get direction of main note stem +c + if (.not.beamon(ivx)) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. + * tnote(ipl2(ivx,ip)).gt.63 + call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0, + * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur) + end if + end if + end if + if (btest(iornq(ivx,ip),24)) then +c +c Start slur on main note for After- or Way-after-grace. +c +c???? ndxslur = log2(33554431-listslur) + ndxslur = log2(16777215-listslur) +c +c Get note name +c + call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) +c +c Get slur direction +c + slurudq = 'u' + if (.not.beamon(ivx)) then + if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd' + else + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd' + end if +c +cc Replace ndxslur by 11-ndxslur when printing only. +c Replace ndxslur by 23-ndxslur when printing only. +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c notexq = sq//'islur'//slurudq//chax(59-ndxslur) + notexq = sq//'islur'//slurudq//chax(71-ndxslur) + * //noteq(1:lnoten) + call addstr(notexq,8+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + else + notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + end if +c call setbits(ipl(ivx,ip),4,23,ndxslur) + call setbits(ipl(ivx,ip),5,23,ndxslur) + if (btest(ipl(ivx,ip),31)) +c +c Starting slur on W-grace on THIS note. Record ndxslur. +c + * listslur = ibset(listslur,ndxslur) + end if + end if +c +c Process dynamic marks +c + if (btest(irest(ivx,ip),26)) then + call dodyn(ivx,ip, + * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip), + * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq, + * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout) + end if +c +c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. +c + if (btest(ipl(ivx,ip),10)) then +c +c Need a duration to set type of note head +c +c if (.not. vxtup(ivx)) then +c +c Clumsy test, but vxtup is not set until main note is processed. +c + if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then + nodu = nodur(ivx,ip) +c else if (mult(ivx,ip) .lt. 0) then + else if (iand(mult(ivx,ip),15)-8 .lt. 0) then + nodu = 32 + else + nodu = 16 + end if + call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout, + * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv, + * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen, + * btest(nacc(ivx,ip),27),nacc(ivx,ip)) + end if +c +c Now that chords are done, add stuff to midi file +c +c if (ismidi) call addmidi(icm,nolev(ivx,ip), + if (ismidi) call addmidi(icm, + * nolev(ivx,ip)-iTransAmt(instno(iv)), +c + * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)), + * btest(irest(ivx,ip),0),.false.) +c +c Check for breath or caesura +c + if (btest(iornq(ivx,ip),28)) then + call putcb(ivx,ip,notexq,lnote) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Check for main-note ornaments. ')' on dotted notes go in with note, not here. +c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD +c + isacc = iand(iornq(ivx,ip),4194287) .gt. 0 +c +c isacc=.true. if any ornament except segno +c + if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then +c +c If ). is only ornament, bypass. If with others, temporarirly zero the bit. +c + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (iand(iornq(ivx,ip),516079) .eq. 0) then +c +c ). is the only non-segno ornament +c + isacc = .false. + else +c +c There are other ornaments in addition +c + rpndot = .true. + iornq(ivx,ip) = ibclr(iornq(ivx,ip),13) + end if + end if + end if + if (isacc .and. .not.cwrferm(ivx)) then +c +c Check for centered whole-bar rest with fermata (bits 10 or 14). +c + if (iand(iornq(ivx,ip),17408).gt.0 + * .and. btest(irest(ivx,ip),0) .and. + * nodur(ivx,ip).eq.lenbar .and. + * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then + cwrferm(ivx) = .true. + go to 30 + end if + call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip), + * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen, + * notexq,lnote,ip,islhgt,beamon(ivx), + * btest(ipl(ivx,ip),10)) + call addstr(notexq,lnote,soutq,lsout) + end if + if (rpndot) then + iornq(ivx,ip) = ibset(iornq(ivx,ip),13) + rpndot = .false. + end if +30 continue +c +c Check for main note accidental +c + if (iand(nacc(ivx,ip),3).gt.0 .and. + * .not.btest(nacc(ivx,ip),17)) then + ihshft = igetbits(nacc(ivx,ip),7,10) + if (ihshft .ne. 0) ihshft=ihshft-107 + if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8)) +c +c Not a chord, and left-shifted main note, so left-shift accid +c + * ihshft = ihshft-20 + call doacc(ihshft,igetbits(nacc(ivx,ip),6,4), + * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip), + * btest(irest(ivx,ip),31)) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Lower dot for lower-voice notes. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest +c. 5. Flag (lowdot) is set to true +c 6. Not in an xtuplet +c + if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv + * .and. nodur(ivx,ip).ne.0) then + if (.not.btest(irest(ivx,ip),0) .and. + * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and. + * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then + if (btest(irest(ivx,ip),19)) then +c +c Note already in movdot list. Drop by 2. +c + updot(ivx,ndotmv(ivx)+1) = + * updot(ivx,ndotmv(ivx)+1)-2. + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout, + * igetbits(islur(ivx,ip),1,3)) + end if + end if + end if +c +c Check for dotted notes with moved dots +c + if (btest(irest(ivx,ip),19)) then + ndotmv(ivx) = ndotmv(ivx)+1 + call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)), + * soutq,lsout,igetbits(islur(ivx,ip),1,3)) + end if +c +c Stemlength shortening? +c + if (btest(mult(ivx,ip),27)) then + stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5 + call addstr(sq//'stemlength{',12,soutq,lsout) + write(notexq,'(f4.2)')stemshort + call addstr(notexq(1:4)//'}',5,soutq,lsout) + else if (ip .gt. 1) then + if (btest(mult(ivx,ip-1),27)) +c +c Cancel shortening. Looks like it gets automatically restored if new inst. or +c new line, so no need to worry about affecting other lines +c + * call addstr(sq//'stemlength{4.66}',17,soutq,lsout) + end if +c +c Zero out slur-height marker for raising ornaments +c + islhgt = 0 +c +c Now start with spacing notes. Is a beam start pending? +c + if (bspend .and. + * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then + if (ixrest(ivx) .eq. 4) then +c +c Special path for single note at end of otherwise beamed xtup +c + ixrest(ivx) = 0 + else + call beamn1(notexq,lnote) + end if + bspend = .false. +c +c Is a beam ending? +c + else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then + * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or. + * btest(nacc(ivx,ip),20))) then + if (bspend) then +c +c Must be a single-note ending of a jump-beam +c + bspend = .false. + end if + call beamend(notexq,lnote) + if (.not.btest(nacc(ivx,ip),20)) then + vxtup(ivx) = .false. + nornb(ivx) = 0 + ibmcnt(ivx) = ibmcnt(ivx)+1 + beamon(ivx) = .false. + end if +c +c Or if we're in the middle of a beam +c + else if (numbms(ivx).gt.0 .and. beamon(ivx)) then + call beamid(notexq,lnote) +c +c Or whole-bar rest +c + else if (btest(irest(ivx,ip),0) + * .and. nodur(ivx,ip).eq.lenbar + * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0) + * .and..not.btest(irest(ivx,ip),25) + * .and..not.btest(islur(ivx,ip),29)) then +c +c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp +c + cwrest(ivx) = .true. + iscwr = .true. + call notex(cwrq(ivx),lcwr(ivx)) + tnow = tnow+lenbar + go to 10 + else if (ixrest(ivx) .eq. 0) then +c +c Before writing note or rest, check for keyboard rest height adjustment. +c Conditions are 0. This is a non-blank rest +c 1. kbdrests = .true. +c 2. There are two voices on the staff +c 3. No user-def height adjustments have been applied (nolev<50) +cc 4. Not last note in bar +cc 5. Followed by note (add better test later) +c + if (kbdrests .and. btest(irest(ivx,ip),0) .and. + * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. +c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) +c * .and. .not.(btest(irest(ivx,ip+1),0))) then + * nolev(ivx,ip).le.50) then +c +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 + end if +2 continue +c +c Write a separate note or rest +c + call notex(notexq,lnote) + end if +c +c Right offset? This may cause trouble +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (ixrest(ivx).eq.0 .and. lnote.gt. 0) + * call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) +c +c Terminate user-defined offsets. Fix format +c + if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) + * call putshft(ivx,.false.,soutq,lsout) +c +c Deal with After- and Way-after-graces. First, if end of bar, compute space +c needed since it wasn't done during general ask-checks. If extra space is +c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. +c But will still need to add extra space as hardspace. +c + if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or. + * btest(ipl(ivx,ip),29))) then + do 77 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78 +77 continue + print*,'Problem finding grace index at "do 77"' + call stop1() +78 continue +c +c Get elemskip to end of bar. WON'T WORK IF XTUPS !! +c + esk = 0. + do 40 iib = ib , nb + if (iib .eq. ib) then + itleft = nint(to(ipl2(ivx,ip))) + else + itleft = nint(tstart(ib)) + end if + if (iib .lt. nb) then + itright = nint(tstart(iib+1)) + else + itright = lenbar + end if + esk = esk+feon(space(ib))* + * (itright-itleft)/space(ib) +40 continue + ptsavail = poenom*esk-wheadpt + if (nng(ig) .eq. 1) then + wgr = grafac + else + wgr = nng(ig)*emgfac + do 41 ing = 1 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +41 continue + end if + ptgr(ig) = wgr*wheadpt + ptsneed = (wgr+0.5)*wheadpt + ptsndg(ivx) = 0. + if (ptsavail .lt. ptsneed) then + ptsndg(ivx) = ptsneed + eskndg(ivx) = esk + if (btest(ipl(ivx,ip),31)) then +c +c Convert GW to GA +c + ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29) + end if + end if + end if +c +c Check for GA +c + if (btest(ipl(ivx,ip),29)) + * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,ip),.false., + * .false.,0,0,0,0,0,0,0.,ulq) +c +c Update running time +c + tnow = tnow+space(ib) +10 continue +c +c Have finished last note in this voice and block +c + itendb = nint(to(istop(ib))+space(ib)) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 +17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then +c +c There's at least one figure left. offnsk could be <0 +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout) + go to 17 + end if + end if +c +c Check for flag, dot, or upstem on last note of bar. +c + if (ib .eq. nb) then + ip = ipo(ipl2(ivx,nn(ivx))) + flgndv(ivx) = 0. + if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then + if (space(ib) .lt. 16.-tol) then +c +c Note in last space, smaller than a quarter note. +c + if ((.not.btest(irest(ivx,ip),0) .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') + * .or. isdotted(nodur,ivx,ip)) then +c +c Upstem non-rest, or dotted +c + if (numbms(ivx).gt.0 + * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx))) + * .and. .not.isdotted(nodur,ivx,ip)) + * then +c +c In beam and not dotted, so use smaller space +c + flgndv(ivx) = upstmfac + else + flgndv(ivx) = flagfac + end if + end if + else +c +c Last space, nonflagged (no beam) only worry dot or up +c + if (isdotted(nodur,ivx,ip)) then + flgndv(ivx) = flagfac + else if (tnote(ipl2(ivx,ip)).lt.64 .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') then +c +c Upstem on last note , non-flagged +c + flgndv(ivx) = upstmfac + end if + end if + end if +c +c Check for right-shifted chordal note +c + if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac + flgndb = flgndb .or. flgndv(ivx).gt.0. + if (ismidi) then +c +c For midi, set flags for accidentals on last note of bar. Assume they affect +c first note of next bar whether or not tied. +c Note has already been done, so next entry into addmidi is 1st in new bar. +c First do main note, then chord notes +c +c Gyrations needed to account for multi-bar tied full-bar notes? +cc Old old lbacc(icm) = iand(nacc(ivx,ip),7) +c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) +c + if (iand(nacc(ivx,ip),7) .gt. 0) then +c +c Explicit accidental on last main note in bar +c + do 55 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56 +55 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolev(ivx,ip) + jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7)) + end if +56 continue + if (btest(ipl(ivx,ip),10) .and. crdacc) then + do 57 icrd = icrd1 , icrd2 + iacc = igetbits(icrdat(icrd),3,20) + if (iacc .gt. 0) then +c +c Explicit accidental on chord note at end of bar +c + nolevc = igetbits(icrdat(icrd),7,12) + do 58 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolevc) go to 59 +58 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolevc + jaccbl(icm,naccbl(icm)) = iashft(iacc) + end if +59 continue +57 continue + end if +c if (lbacc(icm).eq.0 .and. accb4(icm)) then + do 65 kacc = 1 , naccim(icm) +c +c If naccim(icm)>0, +c possible implicit accidental from earlier in the bar. Check for prior accid +c in this bar at relevant note levels, main and chord notes. Only act if no +c explicit action from just above. Assuming any accid on last note in bar, +c either explicit or implicit, has same effect on 1st note of next bar. +c + if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66 + if (btest(ipl(ivx,ip),10)) then + do 67 icrd = icrd1 , icrd2 + if (iand(ishft(icrdat(icrd),-12),127) .eq. + * laccim(icm,kacc)) go to 66 +67 continue + end if + go to 65 +66 continue +c +c So far we know there is a main or chord note at level laccim(icm,kacc). So +c it will get a bl-accid if it didn't just already get one. +c + do 68 macc = 1 , naccbl(icm) + if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 +68 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = laccim(icm,kacc) + jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc) +65 continue + end if + end if +11 continue +c +c Close out the notes group +c + call addstr(sq//'en',3,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' +16 continue +c +c Check for way-after graces at end of bar. We could not link these to notes +c as in midbar since there is no note following grace! Also, set flag if +c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. +c + isgrace = .false. + do 75 iv = 1 , nv + nvmxsav(iv) = nvmx(iv) + do 75 kv = 1 , nvmx(iv) + ivmxsav(iv,kv) = ivmx(iv,kv) + ivx = ivmx(iv,kv) + ptsgnd = 0. + if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31)) + * .and. ptsndg(ivx).gt.0.) then + flgndb = .true. + if (ptsndg(ivx) .gt. ptsgnd) then + ptsgnd = ptsndg(ivx) + eskgnd = eskndg(ivx) + end if + end if + if (btest(ipl(ivx,nn(ivx)),31)) then +c +c This voice has a way-after grace here at end of bar +c + if (.not.isgrace) then +c +c This is the first one, so set up the string +c + isgrace = .true. + ivlast = 1 + soutq = sq//'znotes' + lsout = 7 + end if + do 76 iiv = ivlast , iv-1 + call addstr(sepsymq(iiv),1,soutq,lsout) +76 continue + ivlast = iv +c +c No need to put in 'nextvoice', even if 2 lines/staff +c + call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)), + * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true., + * .false.,0,0,0,0,0,0,0.,ulq) + end if +75 continue + if (isgrace) then + call addstr(sq//'en%',4,soutq,lsout) + if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout) + end if + lsout = 0 +c +c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest +c This has to be the only use of atnextbar +c +c if (ibar .eq. ibarmbr) then + if (ibar.eq.ibarmbr .and. islast) then +c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// +c * 'mbrest{',30,soutq,lsout) +c ndig = int(alog10(mbrest+.01))+1 +c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest +c lsout = lsout+ndig +c call addstr('}{',2,soutq,lsout) +c mtrspc = .5+xb4mbr +c xb4mbr = 0. +c if (mtrspc .eq. 0) then +c ndig = 1 +c else +c ndig = int(alog10(mtrspc+.01))+1 +c end if +c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc +c lsout = lsout+ndig +c call addstr('}0'//sq//'en}%',7,soutq,lsout) +c if (islast) write(11,'(a)')soutq(1:lsout) +c lsout = 0 +c ndig = int(alog10(mbrest-1+.01))+1 +c if (mbrest.eq.1) ndig=1 +c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') +c * sq//'advance'//sq//'barno',mbrest-1,'%' +c++ + soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes' + lsout = 22 + notexq = sq//'mbrest' + lnote = 7 + call istring(mbrest,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + mtrspc = .5+xb4mbr + xb4mbr = 0. + call istring(mtrspc,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len)//'0' + lnote = lnote+len+1 + do 62 iv = 1 , nv + call addstr(notexq,lnote,soutq,lsout) + if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout) +62 continue + call addstr(sq//'en}%',5,soutq,lsout) + write(11,'(a)')soutq(1:lsout) + lsout = 0 + if (mbrest .gt. 1) then + ndig = int(alog10(mbrest-1+.01))+1 + write(11,'(a14,i'//chax(48+ndig)//',a1)') + * sq//'advance'//sq//'barno',mbrest-1,'%' + end if + else if (iscwr) then +c +c Centered whole-bar rests +c + call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, + * soutq,lsout) + do 60 iv = 1 , nv + lnote = 0 + do 61 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (cwrest(ivx)) then + if (lnote .eq. 0) then + notexq = sq//'centerbar{' + lnote = 11 + end if + if (.not.cwrferm(ivx)) then + if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then +c +c Kluge to use new definitions for centered, stacked rests +c + if (cwrq(ivx)(2:10).eq.'liftpause' .or. + * cwrq(ivx)(2:10).eq.'liftPAuse') + * cwrq(ivx)(10:10) = 'c' + end if + notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+lcwr(ivx) + else +c +c Fermata on centered rest. Will need to fix up level. +c 12/6/07 shift it left so it's centered over rest +c +c notexq = notexq(1:lnote) +c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) +c lnote = lnote+11+lcwr(ivx) +c + notexq = notexq(1:lnote)//sq//'loffset{.39}{' + * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+26+lcwr(ivx) + cwrferm(ivx) = .false. + end if + end if +61 continue + if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1, + * soutq,lsout) + if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) +60 continue + call addstr(sq//'en}',4,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' + end if +c +c End of block for centered whole-bar rests and multi-bar rests +c +c If at end of block, save durations of last notes in bar, for possible use +c if clef changes at start of next bar +c + if (ibar .eq. nbars) then + do 63 iv = 1 , nv + do 63 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) +c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) + prevtn(ivx) = tnote(ipl2(ivx,nn(ivx))) +63 continue + end if +c +c Update time for midi. This is only used for the event track +c + if (ismidi) then + miditime = miditime+15*lenbar +c +c If pickup, write the real time signature to the event track. Cannot use +c mtrnuml since it was reset to 0, have to recompute it +c + if (lenb0 .eq. lenbar) + * call midievent('m',mtrdenl*lenb1/64,mtrdenl) + end if + return + end + subroutine makeabar() +c +c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for +c xtups, since only last note of xtup gets non-zero nodur, which +c corresponds to single note of full length of xtup. +c In this subroutine we make an ordered list of all notes in all voices. +c ilnc = list note counter +c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. +c to(ilnc) = real start time of note in PMX-units (64=whole note) +c tno(ilnc) = time to next event in the bar. +c tnote(ilnc) = actual duration of note +c Then run thru list, grouping consecutive notes into \notes groups ib. +c space(ib) = real time unit for the \notes group +c squez(ib) = factor on space to get effective space. This will be 1 if +c there is a note exactly spanning each interval of space, and +c <1 if not. +c Details: let eon = elemskips per noteskip (like length). Basic formula is +c eon = sqrt(space/2.) +c If tgovern >= space, then +c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). +c Time needed to give this eon using basic formula is +c teq = space**2/tgovern +c Factor on space to get teq is +c squez(ib) = space/tgovern +c The eon for each ib can then be computed based on time of space*squez. +c Iff squez = 1, there is a note spanning every increment in the \notes group. +c +c tnminb = minimum time span in the bar for increments spanned by notes, +c i.e., with squez=1. Use after parsing into line to decide if +c spacing needs to be "flattened" among notes groups. +c + common /comtol/ tol + parameter (nm=24,nkb=3999,maxblks=4000) + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + logical rest,firstline,newmeter,gotclef + integer cnn(nm),istart(80),istop(80) + real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600) + elskb = 0. + tnminb(ibarcnt) = 1000. + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv) +c + ilnc = 1 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cnn(ivx) = 1 + ivxo(ilnc) = ivx + ipo(ilnc) = 1 + to(ilnc) = 0. + tnote(ilnc) = fnote(nodur,ivx,1,nacc) + xit(ivx) = tnote(ilnc) + if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000. + ilnc = ilnc+1 +4 continue +c +c Build the list +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iv = 1 , nv + do 6 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + tminn = min(tmin,xit(ivx)) + if(tminn .lt. tmin) then + tmin = tminn + ivnext = ivx + end if +6 continue + if (tmin .gt. 999.) go to 7 + ivxo(ilnc) = ivnext + cnn(ivnext) = cnn(ivnext)+1 + ipo(ilnc) = cnn(ivnext) + to(ilnc) = tmin +c +c Check if this voice is done +c + tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc) + if (cnn(ivnext) .eq. nn(ivnext)) then + xit(ivnext) = 1000. + else + xit(ivnext) = xit(ivnext)+tnote(ilnc) + end if + ilnc = ilnc+1 + go to 5 +7 continue + ntot = ilnc-1 + if (ntot .gt. 600) then + call printl(' ') + call printl('Cannot have more than 600 notes per bar, stopping') + call stop1() + end if + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc) + tnote(ntot) = tno(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(tnote(in),in=1,ntot) +c +c Done w/ list. Initialize loop for building note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c Start the loop +c +9 continue + if (in .eq. ntot) then + if (space(ib) .lt. tol) then + space(ib) = tno(in) +c +c Last gap in bar is spanned by a note, so cannot need a squeeze. +c + squez(ib) = 1. + end if + istop(ib) = ntot +c +c From here flow out of this if block and into block-setup +c + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else +c +c Tentative space tno(in) is non-zero. Set squez, which will be kept (since +c it is a unique property of the particular increment starting here) : +c + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the space, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then +c +c Next increment has same space. Does it have same squez? +c + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) +c +c If it does have the same squez, loop, otherwise flow out +c + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart, istop, space, and squez are good, so close out block +c + tstart(ib) = to(istart(ib)) +c +c Compute elemskips assuming no flattening to increase min space. The formula +c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible +c flattening in pmxb), elsperns = squez*feon(space/squez) +c + elsperns = f1eon(space(ib)*squez(ib)) + if (istop(ib) .eq. ntot) then + nnsk = nint((lenbar-tstart(ib))/space(ib)) + else + nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib)) + end if + elskb = elskb+elsperns*nnsk + if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then + call catspace(space(ib),squez(ib),nnsk) + else +c +c This is the first entry for this bar +c + nnpd(nptr(ibarcnt)) = nnsk + durb(nptr(ibarcnt)) = space(ib) + sqzb(nptr(ibarcnt)) = squez(ib) + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + end if +c +c Update minimum space spanned by a note +c + if (abs(squez(ib)-1) .lt. tol) + * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib)) + if (istop(ib) .eq. ntot) go to 15 +c +c End of spatial accounting for now +c + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space for new block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue +c nb = ib +c +c Debug writes +c +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c + return + end + subroutine midievent(typeq,in1,in2) +c +c We now store "conductor" events in mmidi(numchan,.), and count bytes +c with imidi(numchan) +c + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comevent/ miditime,lasttime + character*1 typeq + idur = isetvarlen(miditime-lasttime,nbytes) + imidi(numchan) = imidi(numchan)+nbytes+1 + do 1 i = 1 , nbytes + mmidi(numchan,imidi(numchan)-i) = mod(idur,256) + idur = ishft(idur,-8) +1 continue + mmidi(numchan,imidi(numchan)) = 255 + if (typeq .eq. 't') then +c +c Tempo event. in1 = quarters per minute (integer) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+1 + mmidi(numchan,imidi(numchan)+2) = 3 + misperq = nint(60000000./in1) + do 2 i = 1 , 3 + mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256) + misperq = ishft(misperq,-8) +2 continue + imidi(numchan) = imidi(numchan)+5 + else if (typeq .eq. 'm') then +c +c Meter event. in1=numerator, in2=denom (power of 2) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+8 + mmidi(numchan,imidi(numchan)+2) = 4 + mmidi(numchan,imidi(numchan)+3) = in1 + if (in2 .gt. 0) then + mmidi(numchan,imidi(numchan)+4) = log2(in2) + else + mmidi(numchan,imidi(numchan)+4) = 0 + end if + mmidi(numchan,imidi(numchan)+5) = 24 + mmidi(numchan,imidi(numchan)+6) = 8 + imidi(numchan) = imidi(numchan)+6 + else if (typeq .eq. 'k') then +c +c Keychange event. in1 = isig +c + mmidi(numchan,imidi(numchan)+1) = 5*16+9 + mmidi(numchan,imidi(numchan)+2) = 2 + mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256) + mmidi(numchan,imidi(numchan)+4) = 0 + imidi(numchan) = imidi(numchan)+4 + else + print*,'Program flameout in midievent' + call stop1() + end if + lasttime = miditime + return + end + subroutine moveln(iuin,iuout,done) + logical done + character*129 outq + done = .false. + read(iuin,'(a)',end=1) outq + lenout = llen(outq,129) + write(iuout,'(a)') outq(1:lenout) + return +1 done = .true. + return + end + subroutine mrec1(lineq,iccount,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + function ncmid(iv,ip) + parameter (nm=24) + common /all/ mult(nm,200),jv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + if (ncc(iv) .eq. 1) then + ncmid = ncmidcc(iv,1) + else + xtime = to(ipl2(ivx,ip)) + do 1 icc = ncc(iv) , 1 , -1 + if (xtime .gt. tcc(iv,icc)-tol) then + ncmid = ncmidcc(iv,icc) + return + end if +1 continue + print*,'Problem in ncmid()' + stop + end if + end + function ncmidf(clefq) +c +c Return middle line of a clef +c + character*1 clefq +c if (clefq.eq.'t' .or. clefq.eq.'0') then +c ncmidf = 35 +c else if (clefq.eq.'s' .or. clefq.eq.'1') then +c ncmidf = 33 +c else if (clefq.eq.'m' .or. clefq.eq.'2') then +c ncmidf = 31 +c else if (clefq.eq.'a' .or. clefq.eq.'3') then +c ncmidf = 29 +c else if (clefq.eq.'n' .or. clefq.eq.'4') then +c ncmidf = 27 +c else if (clefq.eq.'r' .or. clefq.eq.'5') then +c ncmidf = 25 +c else if (clefq.eq.'f' .or. clefq.eq.'7') then +c ncmidf = 37 +c else +c ncmidf = 23 +c end if + ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 + return + end + subroutine newvoice(jv,clefq,change) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + character*1 ulfbq,clefq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical change,autofbon + nvmx(jv) = 1 + ivmx(jv,1) = jv + itsofar(jv) = 0 + nnl(jv) = 0 + nfb(jv) = 0 + if (firstgulp .or. change) then + ncmidcc(jv,1) = ncmidf(clefq) + else + ncmidcc(jv,1) = ncmidcc(jv,ncc(jv)) + end if + tcc(jv,1) = 0. + ncc(jv) = 1 + nudoff(jv) = 0 + ndotmv(jv) = 0 + do 5 j = 1 , 200 + irest(jv,j) = 0 + islur(jv,j) = 0 + ipl(jv,j) = 0 + nacc(jv,j) = 0 + iornq(jv,j) = 0 + mult(jv,j) = 0 + if (jv.le.2) isfig(jv,j) = .false. +5 continue + return + end + subroutine notefq(noteq,lnote,nolev,ncmid) +c +c Returns name of note level with octave transpositions, updates noctup. +c + common /comoct/ noctup + character*8 noteq + character*1 upcaseq,noteqt,chax + nupfroma = mod(nolev+1,7) + iname = 97+nupfroma + ioctup = (nolev+1)/7-4 + noteqt = chax(iname) + if (ncmid .eq. 23) noteqt = upcaseq(noteqt) + if (ioctup .eq. noctup) then + noteq = noteqt + lnote = 1 +c +c Must ALWAYS check if lnote=1 for use with functions requiring a blank +c + else if (ioctup .gt. noctup) then +c +c Raise octave. Encase in {} +c + write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1), + * noteqt,'}' + lnote = 3+ioctup-noctup + noctup = ioctup + else +c +c Lower octave +c + write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1), + * noteqt,'}' + lnote = 3+noctup-ioctup + noctup = ioctup + end if + return + end + subroutine notex(notexq,lnote) +c +c Returns non-beamed full note name +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig,ispoi,btest,even + character*1 udq,udqq,chax + character*4 dotq + character*2 numq + character*79 notexq + character*8 noteq + character*40 restq + common /compoi/ ispoi + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + nodu = nodur(ivx,ip) + if (.not.btest(irest(ivx,ip),0)) then + udq = udqq(nole,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) + end if +c +c Check figure level +c +c if (figbass .and. isfig(ivx,ip) +c * .and. .not.btest(irest(ivx,ip),0)) then + if (figbass .and. .not.btest(irest(ivx,ip),0) .and. + * ((ivx.eq.1.and.isfig(1,ip)) + * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then + if (udq .eq. 'u' .or. nodu.ge.64) then +c +c Upper or no stem, fnole (in noleunits) set by notehead +c + fnole = nole + else +c +c Lower stem, fnole set by bottom of stem +c + fnole = nole-stemlen + end if + zmin = fnole-ncmid(ivx,ip)+4 + if (ivx .eq. 1) then + ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin)) + else + ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin)) + end if + end if + if (.not.btest(irest(ivx,ip),0)) then + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + if (nodu .eq. 1) then + notexq =sq//'cccc'//udq//noteq(1:lnoten) + lnote = lnoten+6 + else if (nodu .eq. 2) then + notexq =sq//'ccc'//udq//noteq(1:lnoten) + lnote = lnoten+5 + else if (nodu .eq. 4) then + notexq =sq//'cc'//udq//noteq(1:lnoten) + lnote = lnoten+4 + else if (nodu .eq. 8) then + notexq =sq//'c'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 16) then + notexq =sq//'q'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 32) then + notexq =sq//'h'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 64) then + notexq =sq//'wh'//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 128) then +c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' +c lnote = lnoten+10 + notexq =sq//'breve'//noteq(1:lnoten) + lnote = lnoten+6 + else + dotq = 'p' + ldot = 1 + if (btest(iornq(ivx,ip),13)) then +c +c Dotted note with ')' ornament +c + dotq='m' + else if (btest(islur(ivx,ip),3)) then +c +c Double dot +c + dotq = 'pp' + ldot = 2 + end if + if (nodu .ge. 192) then + notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+6+ldot + else if (nodu .ge. 96) then + notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 48) then + notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 24) then + notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 12) then + notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 6) then + notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+4+ldot + ispoi = .true. + else + notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+5+ldot + ispoi = .true. + end if + if (dotq(1:1) .eq. 'm') then +c +c Need another call to the note, in case the first one has octave shifts +c + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + end if + else if (btest(islur(ivx,ip),29)) then +c +c Blank rest +c + notexq = sq//'sk' + lnote = 3 + else +c +c Non-blank rest +c + lnote = 0 + nole = mod(nole+20,100)-20 +c +c Kluge to get pause symbol for rp: +c + if (btest(islur(ivx,ip),19)) nodu = 64 + if (nodu .le. 28) then +c +c Normal rest < or = double-dotted quarter +c + lrest = 3 + if (nodu .gt. 14) then + restq =sq//'qp' + else if (nodu .gt. 7) then + restq =sq//'ds' + else if (nodu .gt. 3) then + restq =sq//'qs' + else if (nodu .gt. 1) then + restq =sq//'hs' + else + restq =sq//'qqs' + lrest = 4 + end if +c if (2**log2(nodu) .ne. nodu) then +cc +cc One or two dots on rest +cc +c restq = restq(1:3)//'p' +c lrest = 4 +c if (2*nodu .gt. 3*2**log2(nodu)) then +cc +cc Double dotted rest +cc +c restq = restq(1:4)//'p' +c lrest = 5 +c end if +c end if + notexq = restq + lnote = lrest +c +c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. +c + if (nole .ne. 0) then + if (abs(nole) .lt. 10) then + noteq = chax(48+abs(nole)) + lnoten = 1 + else + write(noteq(1:2),'(i2)')abs(nole) + lnoten = 2 + end if + if (nole .gt. 0) then + notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' + else + notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' + end if + lnote = 16+lnoten +c if (2**log2(nodu) .ne. nodu) then +cc +cc Have dot in raised rest. must put in hbox! +cc +c notexq = notexq(1:lnote)//sq//'hbox{' +c lnote = lnote+6 +c end if + notexq = notexq(1:lnote)//restq(1:lrest) + lnote = lnote+lrest +c if (2**log2(nodu) .ne. nodu) then +c notexq = notexq(1:lnote)//'}' +c lnote = lnote+1 +c end if + end if + if (2**log2(nodu) .ne. nodu) then +c +c Deal with dots (on rests shorter than half rest) +c + restq = sq//'pt' + lrest = 3 + if (2*nodu .gt. 3*2**log2(nodu)) then + restq = sq//'ppt' + lrest = 4 + end if + nole = nole+4 + raisedot = 0 +c +c Tweak dot positions for special cases +c + even = (mod(100+nole,2).eq.0) +c if (.not.even.and.nodu.gt.8.and. +c * (nole.lt.0.or.nole.gt.8)) then + if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then + raisedot = 1 + end if + if (nole.ge.10 .or. nole.le.-1) then + write(numq,'(i2)')nole + restq = restq(1:lrest)//'{'//numq//'}' + lrest = lrest+4 + else + restq = restq(1:lrest)//chax(nole+48) + lrest = lrest+1 + end if + if (raisedot.gt.0) then + restq = sq//'raise'//sq//'internote'// + * sq//'hbox{'//restq(1:lrest)//'}' + lrest = lrest+23 + end if + + + + notexq = restq(1:lrest)//notexq(1:lnote) + lnote = lnote+lrest + end if + else +c +c Half rest or longer +c + if (nole .eq. 0) then +c +c Half or longer rest is not raised or lowered +c + if (nodu .le. 56) then + notexq =sq//'hpause' + lnote = 7 + else if (nodu .le. 112) then + if (.not.btest(islur(ivx,ip),19) .or. + * btest(irest(ivx,ip),25)) then + notexq = sq//'pause' + else + notexq = sq//'pausc' + end if + lnote = 6 + else + notexq =sq//'PAuse' + lnote = 6 + end if + if (2**log2(nodu) .ne. nodu) then +c +c Dotted rest, hpause or longer +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + if (2*nodu .gt. 3*2**log2(nodu)) then +c +c Double dotted long rest +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if + end if + else +c +c Raised or lowered half or whole rest +c + if (nodu .eq. 32) then + notexq = sq//'lifthpause' + lnote = 11 + else if (nodu .eq. 48) then + notexq = sq//'lifthpausep' + lnote = 12 + else if (nodu .eq. 56) then + notexq = sq//'lifthpausepp' + lnote = 13 + else if (nodu .eq. 64) then + notexq = sq//'liftpause' + lnote = 10 + else if (nodu .eq. 96) then + notexq = sq//'liftpausep' + lnote = 11 + else if (nodu .eq. 112) then + notexq = sq//'liftpausepp' + lnote = 12 + else if (nodu .eq. 128) then + notexq = sq//'liftPAuse' + lnote = 10 + else +c +c Assume dotted double whole rest +c + notexq = sq//'liftPAusep' + lnote = 11 + end if +c +c Set up height spec +c + nole = sign(abs(nole)/2,nole) + if (nole.le.9 .and. nole.ge.0) then + noteq = chax(48+nole) + lnoten = 1 + else + noteq = '{' + if (nole .ge. -9) then + write(noteq(2:3),'(i2)')nole + lnoten = 3 + else + write(noteq(2:4),'(i3)')nole + lnoten = 4 + end if + noteq = noteq(1:lnoten)//'}' + lnoten = lnoten+1 + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + end if + end if + return + end + function ntindex(line,s2q,lenline) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q,line + character*1 chax + logical intex + ndxs2 = index(line,s2q) + ndxbs = index(line,chax(92)) + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(line,lenline) + intex = .true. + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(line(ic+1:len),s2q)+ic + else + ntindex = ndxs2 + return + end if + else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then + intex = .false. + else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92)) + * then + intex = .true. + end if +1 continue + end if + return + end + subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote) +c +c This appends to notexq e.g. '\ibbbu1' +c + common /combbm/ isbbm + logical isbbm + character*79 notexq + character*1 char1q,ulqq,chax + character*4 tempq + if (n .ge. 5) isbbm = .true. + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//chax(92)//char1q + else + notexq = chax(92)//char1q + end if + lnote = lnote+2 + do 3 im = 1 , n + notexq = notexq(1:lnote)//'b' + lnote = lnote+1 +3 continue +c +c add the number, 0 if 12 +c +c 5/25/08 Allow >12 +c +c call istring(mod(iv,12),tempq,len) + if (iv .lt. 24) then + call istring(iv,tempq,len) + else if (iv .eq. 24) then + tempq(1:1) = '0' + len = 1 + else + call printl('Sorry, too man open beams') + call stop1() + end if + notexq = notexq(1:lnote)//ulqq//tempq(1:len) + lnote = lnote+1+len + return + end + function numclef(clefq) +c +c Returns the number to be used as argument of \setclef (for MusiXTeX only) + character*1 clefq +c if (ichar(clefq) .lt. 55) then + if (ichar(clefq) .le. 55) then + numclef = ichar(clefq)-48 + if (numclef .eq. 7) numclef = 9 + else + numclef = index('tsmanrbxxf',clefq)-1 + end if + return + end + subroutine outbar(i,jlast) + character*1 chax + nfmt = log10(i+.5)+2 + if (jlast+5+nfmt .lt. 80) then + write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = jlast+5+nfmt + else + write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = 5+nfmt + end if + return + end + subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize) +cccccccccccccccccccccccccccccccccccccccccccccccc +cc cc +cc Subroutine, combine with pmxb.for +cc +cccccccccccccccccccccccccccccccccccccccccccccccc +cc +cc Need to consider X spaces in xtuplets when getting poenom, and +cc maybe fbar? +cc mx06a +cc ID numbers for voices when number of voices is reduced. +cc +cc mx03a +cc account for new fracindent for new movements. +cc +cc Known changes since pmxa. Version 1.1b (see pmxb for longer list) +cc +cc Check ID codes for slurs. +cc Version 1.24 still does not have details for spacing/positioning +cc arpeggios if there are accidentals or shifted notes or crowded scores. +cc Fix problem in 1.22 with arpeggios across multi-line staves +cc Fix problem in 1.22 with flat key signatures +cc Read setup data as strings +cc Warning for octave designation plus +/- +cc Don't pause for volta warning, +cc Macros +cc Correct fsyst to account for transposition and key changes. +cc Check for nbars > nsyst +cc +ccccccccccccccccccccccccccccccccccc + parameter (nm=24,nkb=3999,nks=125,maxblks=4000) + logical loop,usefig,isfirst,optimize + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + integer nn(nm),nodur(nm,200),ivxo(600),ipo(600), + * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600) + character*128 lnholdq + character*44 basenameq + logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt, + * stickyS + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr, + * shifton,barend + common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml, + * nodur,lenbar,iccount,nbars,itsofar,nib,nn, + * rest,lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + common /comeon/ eonk,ewmxk + logical mrecord,mplay,endmac,gotclef,cstuplet + logical novshrinktop,upslur,fontslur,WrotePsslurDefaults + common /comnvst/ novshrinktop,cstuplte + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + data wtimesig,wclef,wkeysig + * / 0.72 , 0.8 , 0.28 / + whead20 = 0.3 + if (.not.optimize) then + print* + print*,'Starting first PMX pass' + write(15,'(a)') ' Starting first PMX pass' + end if + if (isfirst) then + open(19,file='pmxaerr.dat') + write(19,'(i6)') 0 + close(19) + end if + if (.not.optimize) jprntb = 81 + macuse = 0 + ornrpt = .false. + stickyS = .false. + mrecord = .false. + mplay = .false. + lastchar = .false. + novshrinktop = .false. + cstuplet = .false. + fontslur = .true. + isligfont = .false. + fulltrans = .false. + do 42 ibarcnt = 1 , nkb + udsp(ibarcnt) = 0. + wminnh(ibarcnt) = -1. +42 continue +c +c Initialize input buffer +c + lenbuf0 = ipbuf + ipbuf = 0 + ilbuf = 1 + call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb) +c +c Set up list of instrument numbers (iv) +c + ivnow = 0 + do 13 instnow = 1 , noinst + do 14 iscount = 1 , nsperi(instnow) + ivnow = ivnow+1 + instno(ivnow) = instnow +14 continue +13 continue +c +c Save initial meter for midi +c + if (.not.isfirst .and. npages.eq.0) then + print*,'Sorry, must have npages>0 for optimization.' + call stop1() + end if + nsyout = nsyst +c +c isig1 will be changed in getnote if there is a transposition +c + isig1 = newkey(1) + if (npages .gt. nsyst) then + call printl('npages > nsyst in input. Please fix the input.') + call stop1() + end if +c +c fbar = afterruleskip/elemskip +c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt +c + fbar = 1. + wheadpt = whead20*musize + ifig = 0 + usefig = .true. + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbr1 = lenmult*mtrnuml*lenbeat + lenbr0 = nint(lenmult*xmtrnum0*lenbeat) + mtrnuml = 0 + if (lenbr0 .ne. 0) then + ibaroff = 1 + lenbar = lenbr0 + else + ibaroff = 0 + lenbar = lenbr1 + end if + ibarcnt = 0 + nptr(1) = 1 + iccount = 128 + nmovbrk = 0 + nflb = 0 + nfpb = 0 + ipagfpb(0) = 1 + isysfpb(0) = 1 + ibarflb(0) = 1 + isysflb(0) = 1 + nistaff(0) = nv-1 +c +c Check for pmx.mod +c + linesinpmxmod = 0 +c line1pmxmod = ilbuf + call getpmxmod(.true.,' ') + if (.not.isfirst .and. linesinpmxmod .gt. 0) then + print*,'Sorry, cannot optimize if there is a pmx.mod file' + call stop1() + end if +c +c Initialize for loop over lines +c + nkeys = 1 + ibrkch(1) = 1 + mbrestsav = 0 + shifton = .false. + firstline = .true. + newmeter = .false. + ihead = 0 + isheadr = .false. + gotclef = .false. + idsig = 0 + iddot = 0 + fintstf = -1. + gintstf = 1.0 + listcresc = 0 + listdecresc = 0 +30 loop = .true. + iskchb = .false. + issegno = .false. + nbars = 0 + ibarmbr = 0 +3 do 4 iv = 1 , nv + nvmx(iv) = 1 + ivmx(iv,1) = iv + itsofar(iv) = 0 + nnl(iv) = 0 + do 5 j = 1 , 200 + rest(iv,j) = .false. + nacc(iv,j) = 0. +5 continue +4 continue + iv = 1 + ivx = 1 + fbon = .false. + barend = .false. + isvolt = .false. +2 if (loop) then +c +c Within this short loop, nv voices are filled up for the duration of a block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nodur(..),rest(..). nnl will later be +c increased and things slid around as accidental skips are added. +c + call g1etnote(loop,ifig,optimize,fulltrans) + if (lastchar) go to 20 + go to 2 + end if + if (mbrestsav .gt. 0) then + call printl(' ') + call printl( + * 'You must enter the same multibar rest in ALL parts') + call stop1() + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 +c +c The following is just a signal to start a new bar when cataloging spaces +c for catspace(...) +c + nptr(ibarcnt+1) = nptr(ibarcnt) + newmb(ibarcnt) = .false. + if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true. +c +c Above is only for spacing calcs later on. Remember new meter can only occur +c at START of a new input line (ibar = 1) +c + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb) + else + if (.not.optimize) then + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + jprntb = 0 + end if + ibaroff = ibaroff-mbrest+1 + end if + if (firstline .and. lenbr0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenbr0 + else + lenbar = lenbr1 + end if + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nodur(ivx,ip) = nodur(ivx,ip+ioff) + rest(ivx,ip) = rest(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) +12 continue +11 continue + end if + do 67 iv = 1 , nv + do 67 kv = 1 , nvmx(iv) + ioff= 0 + if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1) +67 continue + call makeabar() + elsk(ibarcnt) = elskb+fbar +10 continue + newmeter = .false. + firstline = .false. + go to 30 +20 continue +c +c Vertical analysis. +c + if (npages .eq. 0) then + if (nsyst .eq. 0) then + print*,'When npages=0, must set nsyst=bars/syst, not 0' + call stop1() + end if + nsyst = (ibarcnt-1)/nsyst+1 + if (nv .eq. 1) then + nsystpp = 12 + else if (nv .eq. 2) then + nsystpp = 7 + else if (nv .eq. 3) then + nsystpp = 5 + else if (nv .eq. 4) then + nsystpp = 3 + else if (nv .le. 7) then + nsystpp = 2 + else + nsystpp = 1 + end if + npages = (nsyst-1)/nsystpp+1 + end if +c +c Check nsyst vs ibarcnt +c + if (nsyst .gt. ibarcnt) then + print* + print*,'nsyst,ibarcnt:',nsyst,ibarcnt + print*,'There are more systems than bars.' + write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt + write(15,'(a)')' There are more systems than bars.' + call stop1() + end if +c +c Set up dummy forced line & page breaks after last real one +c + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+1 + isysflb(nflb) = nsyst+1 + nfpb = nfpb+1 + ipagfpb(nfpb) = npages+1 + isysfpb(nfpb) = nsyst+1 + heightil = ptheight*4./musize + open(12,status='SCRATCH') + write(12,'(a)')basenameq(1:lbase) + write(12,*)lbase +c +c Pass to pmxb the initial signature, including effect of transposition. +c + write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait, + * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1 + write(12,*)npages,widthpt,ptheight,hoffpt,voffpt,nsyst + iflbnow = -1 + isysb4 = 0 + do 8 ifpb = 1 , nfpb +c +c Each time thru this loop is like a single score with several pages +c + npages = ipagfpb(ifpb)-ipagfpb(ifpb-1) + nsyst = isysfpb(ifpb)-isysfpb(ifpb-1) + nomnsystp = (nsyst-1)/npages+1 + nshort = nomnsystp*npages-nsyst + do 7 ipage = 1 , npages + nsystp = nomnsystp + if (ipage .le. nshort) nsystp = nsystp-1 +c +c Last system number on this page: + isysendpg = isysb4+nsystp + nintpg = 0 + do 15 isy = isysb4+1, isysendpg + if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1 + nintpg = nintpg+nistaff(iflbnow) +15 continue + xilfrac = 0. + xiltxt = 0. + if (ipage.eq.1 .and. ihead.gt.0) then +c +c Needn't zero out ihead after printing titles if we only allow titles at top? +c + if (iand(ihead,1) .eq. 1) then + xiltxt = xiltxt+hgtin*4/musize + xilfrac = xilfrac+etait + end if + if (iand(ihead,2) .eq. 2) then + xiltxt = xiltxt+hgtti*4/musize + xilfrac = xilfrac+etatc + end if + if (iand(ihead,4) .eq. 4) then + xiltxt = xiltxt+hgtco*4/musize + xilfrac = xilfrac+etacs1 + else +c +c Use double the title-composer space if there is no composer +c + xilfrac = xilfrac+etatc + end if + end if + D = xilfrac+nsystp-1+etatop+etabot +c C = nsystp*(nv-1) + C = nintpg +c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn + xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn + if (bottreb) xN = xN-(nsystp-1)*xilbtc + if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr + if (ifig .eq. 1) then + xN = xN - nsystp*xilfig + end if + glueil = (xN-b*C)/(D+a*C) + omegaG = (b*D+a*xN)/(D+a*C) +c +c G = \interlines between systems +c omega*G = \interlines between staves of the same system +c \interstaff = 4+omega*G +c C = total number of interstaff spaces in the page +c D = omega-indep factors for scalable height = nsy-1 (intersystem glue) +c + etatop + etabot + etatxt + +c N = scaleable height (\interlignes) = height - htext - staff heights - xil +c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles +c + (nsy-1)*xiltcb for treble clef bottoms +c + nsy*xilfig for figures +c G = N/(D + omega * C) = glueil, (1) +c But (empirically) omega*G = a*G + b (2) +c with a=1.071 and b=2.714 +c Solving (1) and (2) gives +c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) +c Pass to pmxb omega*G (=\interstaff-4) +c (etatop,bot,it,tc,cx)*G as inputs to \titles +c +c glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) +c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) +c xnsttop = glueil*etatop +c xintstaff = 4+gfact*glueil +c +c Only the first page will get local adjustment now if needed, others in pmxb +c + if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then + facins = fintstf + fintstf = -1. + else +c +c gintstf = 1.0 by default, but may be changed with AI +c + facins = gintstf + end if + write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4) + ihead = 0 + isheadr = .false. + isysb4 = isysendpg +7 continue +8 continue +c +c Done with vertical, now do horizontals +c + celsk(1) = elsk(1) + do 21 ibar = 2 , ibarcnt + celsk(ibar) = celsk(ibar-1)+elsk(ibar) +21 continue + lastbar(0) = 0 + ibar1 = 1 + wmins = -1. + iflb = 1 + imovbrk = 0 + ikey = 1 +c +c Return nsyst to its *total* value +c + nsyst = isysfpb(nfpb)-1 + do 22 isyst = 1 , nsyst + if (isyst .eq. isysflb(iflb)) iflb = iflb+1 + if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then + if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1 + end if + ibarb4 = lastbar(isyst-1) + if (isyst .eq. 1) then + if (isfirst) elsstarg = celsk(ibarflb(1)-1)/ + * (isysflb(1)-1-fracindent)*(1-fracindent) + celskb4 = 0. + else + celskb4 = celsk(ibarb4) +c +c Must dimension isysmb(0:*) just so I can execute this test! +c + if (isfirst) then + if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then +c +c First syst after forced line break. There may be indentation. +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst-fracsys(imovbrk)) + * *(1-fracsys(imovbrk)) + else +c +c There is no indentation to deal with +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst) + end if + end if + end if + if (isfirst) then + diff1 = abs(elsstarg-elsk(ibarb4+1)) + do 23 ibar = ibarb4+2 , ibarcnt + diff = elsstarg-(celsk(ibar)-celskb4) + if (abs(diff) .ge. diff1) go to 24 + diff1 = abs(diff) +23 continue +24 ibar = ibar-1 + lastbar(isyst) = ibar + nbarss(isyst) = ibar-ibarb4 + else +c +c nbarss is given as an input, must compute lastbar and ibar +c + lastbar(isyst) = nbarss(isyst)+ibarb4 + ibar = lastbar(isyst) + end if +c +c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. +c + elss(isyst) = celsk(ibar)-celskb4 + write(12,'(i5)')lastbar(isyst-1)+1 +c +c Transposed sigs are isig1, newkey(2,3,...). +c + if (ikey .eq. 1) then + key1 = isig1 + else + key1 = newkey(ikey) + end if + fsyst = wclef+abs(key1)*wkeysig+2./musize + xelsk = 0. +1 if (ikey.lt.nkeys) then + if (ibrkch(ikey+1).le.lastbar(isyst)) then +c +c Add space for all key changes +c + ikey = ikey+1 + key2 = newkey(ikey) + naccs = max(abs(key2-key1),max(abs(key1),abs(key2))) + fsyst = fsyst+naccs*wkeysig +c +c Account for afterruleskips (fbar) +c + xelsk = xelsk+fbar/2 + if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey)) + * xelsk = xelsk-1. + key1 = key2 + go to 1 + end if + end if +c +c Add extra fixed space for double bar +c + if (isyst .eq. nsyst) then + fsyst = fsyst+4.5/musize + end if +c +c Add extra fixed space for initial time signature +c + if (isyst .eq. 1) then + fsyst = fsyst+wtimesig + end if +c +c Add extra fixed space for time signature changes & user-defined spaces +c + do 26 ibars = ibarb4+1 , lastbar(isyst) + if (newmb(ibars)) fsyst = fsyst+wtimesig + fsyst = fsyst+udsp(ibars)/musize +26 continue + if (isyst .eq. 1) then + wdpt = widthpt*(1-fracindent) + else + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + wdpt = widthpt*(1-fracsys(imovbrk)) + else + wdpt = widthpt + end if + end if + wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst) +c +c Checks for min spacing +c Get min allowable space +c + dtmin = 1000. + do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1 + dtmin = min(dtmin,tnminb(ibar)) + if (wminnh(ibar).ge.0.) wmins = wminnh(ibar) +45 continue + if (wmins .lt. 0) wmins = 0.3 + wminpt = (1+wmins)*0.3*musize +c +c Find max duration & # of notes for this system +c + dtmax = 0. + nns = 0 + do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + dtmax = max(dtmax,durb(iptr)) + nns = nns + nnpd(iptr) +43 continue + elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk) + if (elmin0 .ge. wminpt) then +c +c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; +c there is no need to "flatten" +c + sumelsk = elss(isyst)-fbar*nbarss(isyst) + eonk = 0. + ewmxk = 1. + else + elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns) + if (elmin1 .le. wminpt) then +c print* +c print*,'In system #',isyst,' cannot meet min. space rqmt' +c write(15,'(/a,i5,a)') +c * 'In system #',isyst,' cannot meet min. space rqmt' + eonk = 0.9 + else +c +c Find eonk by Newton method +c +c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) + call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1, + * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax, + * (wminpt-elmin0)/(elmin1-elmin0)) + eonk = min(.9,eonk) + end if + ewmxk = f1eon(dtmax)**eonk +c +c Recompute poenom! +c + sumelsk = 0 + do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + sumelsk = sumelsk + * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr)) +44 continue + end if + poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk) +c +c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 +c + if (isyst .gt. 0) then + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + fracindent = fracsys(imovbrk) + else + fracindent = 0. + end if + end if + write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst), + * sumelsk,fsyst,fracindent,eonk,ewmxk + ibar1 = ibar1+nbarss(isyst) +22 continue + rewind(12) + open(13,status='SCRATCH') + write(13,'(i5)')ifig + rewind(13) + ilbuf = 1 + ipbuf = 0 + if (.not.optimize) then + write(*,'(/,a)')' Done with first pass' + print* + write(15,'(/,a)')' Done with first pass' + write(15,'()') + end if +c +c Following syntax is needed since pmxa is called with literal argument .false. +c + if (isfirst) isfirst = .false. + return + end + subroutine pmxb(inlast,poevec,ncalls,optimize) +cccccccccccccccccccccccccc +cc +cc To Do +cc +cc Resolve disagreement in final poe for 1st system, compared with *.mx2 +cc Shift slurs on right- or left-shifted main notes (2/7/99) +cc Various end-of-input-block repeat problems (ick142.pmx). +cc Force multiplicity for un-beamed xtups. +cc Clef change at end of piece +cc Global "A" option to maximize "X" at a given time tick. +cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted +cc note. See trubl18.pmx +cc Tab character as space. +cc Clef interference with second line of music. +cc Add space for interferences between *different* lines of music? +cc Shift arpeggios, both automatic and manual. +cc Different musicsize for different instruments. +cc Spacing checks for accid's on left-shifted chord notes +cc Spacing checks for double dots +cc Allow forced line breaks w/o setting nsyst. +cc Cresc-Decresc. (Enhance MusiXTeX first?) +cc Dynamic Marks. +cc Bug with Voltas at line end (MusiXTeX problem?). +cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx +cc Stem-end slurs. +cc Allow units in indentation. +cc Make inline TeX more context sensitive. +cc Werner's 4/2/98 problem with "o?" +cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. +cc converts e.g. "r2db" into "r2d", which might be wrong. +cc Werner's generalsignature problem with Key change and new transposition. +cc (wibug8.pmx) +cc Unequal xtuplets +cc Print both sets of bar #'s in tex file. +cc Make barlines invisible \def\xbar{\empty} , fix fbar. +cc Auto-tie slurs 'At' +cc Forced line break anywhere (e.g. at a mid-bar repeat). +cc Clef change at very start of file. +cc Tighten test for M as macro terminator. +cc Fix title so not separate limit on author length + composer length. +cc Arpeggios in xtups. +cc +cc mx10b +cc Option for instrument name at top center. Last item in P command: +cc P[n]c text is instrument name (use in parts) +cc P[n]cstuff text is stuff (up to 1st blank) +cc P[n]c"stuff with spaces" text is stuff with spaces +cc +cc Post version 1.43 +cc Reduced space rqmt for multiplicity-0 graces (no flag) +cc Removed last sepsym in centered whole-bar rests, fixes volta height bug. +cc +cc Version 1.43 +cc Fix spacing for end-of-line signature change. +cc Adjust left-shift of grace group for shifted accidentals. +cc Put in extra space for left-shifted accidentals. +cc Fix bug with dot-shift before accid-shift on chord note. +cc Space-check for right-shifted main notes. +cc Enable forcing stem direction of single notes in non-beamed xtups. +cc Disallow clef change after last note before end of input block (pmxa) +cc Print meter change before page break +cc increase length of strings for \titles macro +cc version 1.42 +cc Loosen up input syntax for "X" commands. Subroutine getx() +cc "B" and "P" in "X" commands +cc mx09b +cc Allow multiple rests at start of xtup +cc Add 64th rest +cc Fix xtup numbers over rests. (subroutine levrn) +cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. +cc c za / ( c a ... +cc Allow double dots to be shifted. +cc Fix spacing with double dotted notes; permit splitting small note. +cc Fix \dotted printout so it works with old compiler +cc mx08b +cc Automatic spaces if needed for shifted accidentals. +cc Some Dynamics +cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) +cc version 1.41 +cc Allow ":" as last char of path name +cc Dotted slurs "sb" +cc Continue bar numbering at movement break "L[integer]Mc" +cc mx07b +cc Whole-bar rests with double lines of music. Fixed all options ? +cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. +cc Option to suppress centering full-bar rests. "o" +cc mx06b +cc Shift accid on left-shifted chord note. +cc Rest as first note of xtup. +cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt +cc Allow Rb for single bar at movemnet break or end of piece. (islur(25)) +cc Change # of inst at a movement break. noinst is total # and must be used +cc in 1st movement. ninow is current. nspern(1,...,ninow) is current +cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to +cc reprint names in parindent at a movement break. Default is .false. +cc unless ninow changes, then .true. But can force either with r+/- as +cc option in 'M' +cc mx04b +cc Double-dotted notes, separate+beamed, main+chord, still no extra space. +cc ??? Don't shift slur ends on whole notes. +cc (pmxa) Write line number of error in pmxaerr.dat +cc mx02b +cc Admit "RD" before "/" (search for "rptfq2:" ) +cc In doslur, for multi-line staves, single notes, check forced stem dir'n +cc before setting stemup (used to set horiz offset). +ccccccccccccccccccccccccccccccc + parameter (nm=24,nks=125,mv=24576,maxblks=4000) +c +c FYI /all/ differs in appearance in function ncmid +c + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) +ccccccccccccc +cc islur cc +ccccccccccccc +c bit meaning +c 0 slur activity on this note +c 1 t-slur here. +c 2 force 0-slope beam starting on this note +c 3 Double dotted note! +c 4 grace before main note +c 5 left repeat +c 6 right repeat +c 7 start Volta +c 8 doublebar +c 9 end Volta +c 10 on=>endvoltabox +c 11 on=>clefchange +c 12-14 0=>treble, ... , 6=>bass +c 15 on=> start new block for clef change (maybe diff. voice) +c 16 literal TeX string +c 17 1=up, 0=down stem for single note (override) See bit 30! +c 18 if on, prohibit beaming +c 19 if on, full bar rest as pause +c 20 Beam multiplicity down-up +c 21 Forced multiplicity for any beam including xtups +c 22-24 Value of forced multiplicity +c 25 single barline at movement break +c 26 doubleBAR (see bits 5,6,8) +c 27-28 Forced beam fine-tune height (1 to 3) +c 29 Blank rest +c 30 If on, get stem dir'n from bit 17 +c 31 If on, suppress printing number with xtuplet starting here +ccccccccccccc +cc ipl cc +ccccccccccccc +cc 0-7 Location in list [0,200] +c 0-7 Unused +c 8 left offset main note one headwidth +c 9 right offset main note one headwidth +c 10 chord present? +c 11-16 Forced beam height adjustment (-30 to +30) +c 17-22 Forced beam slope adjustment (-30 to +30) +c 23-26 Slur index for Way-after grace. Inserted when slur is started. +cc 27 Unused? +c 27 5th bit for slur index for Way-after grace (100712) +c 28 key change: only in voice 1 +c 29 Grace after main note. (Type A) +c 30 In forced beam. Signals need to check beam heights +c 31 Grace way after main note. (stretch to next note, type W) +ccccccccccccc +cc iornq cc +ccccccccccccc +c 0 Ornament "(". Was user-defined horizontal slur shift on this note +c until 9/24/97; changed that to irest(21) +c 1-13 stmgx+Tupf._) +c 14 Down fermata, was F +c 15 Trill w/o "tr", was U +c 16-18 Editorial s,f,n +c 19-20 >^ +c 21 "?" for editorial accid, w/ or w/o s,f,n +c 22 Set if ihornb governs ornament height. Same in icrdorn. +c 23 Set in getorn if ANY note at time of this main note has ornament. +c This is ONLY used in beamstrt to signal whether to do more +c tests for whether ihornb is needed. (ihornb is only needed +c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) +c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. +c 24 Slur on after or way-after grace. Use as signal to START slur. +c 25 Tweak orn ht. Same in icrdorn for chord note +c 26 Insert user-defined space before this note (was 22) +c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord +c 28 caesura or breath +c 29 blank barline (must be iv=1) (would have used islur but no room) +c 30 "Look-left" option for keyboard rest +c 31 Set if any note (main or chord) has cautionary accid, for space checks +ccccccccccccc +cc irest cc +ccccccccccccc +c 0 rest=1, no rest = 0 +c 1 There will be a vertical shift for number of this xtup +c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' +c 7 There is a horizontal shift for xtup number +c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 +c 14 Flip up/down-ness of xtup number +c 15 Single-voice, single note shift X(...)[p]S +c 16 Start single-voice, multinote shift with this note X(...)[p]: +c 17 End single-voice, multinote shift after this note. Enter symbol +c after note. X: +c 18 User-defined hardspace after last note of bar, *after* this note. +c Value still stored in udoff(ivx,nudoff(ivx)), not with other +c hardspaces in udsp, to avoid confusion with time checks. +c 19 Move the dot. Data stored in ndotmv,updot,rtdot +c 20 Set if right-shifted main or chord note here. Use for space checks. +c 21 User-defined hardspace in xtup +c 22 User-defined slur shift horizontal slur shift. +c 23 Set on last note before staff-jumping a beam. +c 24 Set on first note after staff-jumping a beam +c 25 Suppress rest centering. "ro" +c 26 Dynamic on this note +c 27 Set if left-shifted main or chord note here. Use for space checks. +c 28 Set if xtup starts on this note. +c 29 Set on lowest-voice note at same time as 1st note after jump-beam. +c 30 Set on note after end of jump-beam segment, to force new note group +c 31 Flag for cautionary accidental +ccccccccccccc +cc nacc cc +ccccccccccccc +c 0-1 0=no accid, 1=fl, 2=sh, 3=na +c 2 double +c 3 big +c 4-9 vertshift-32 +c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) +c 17 Midi-only accidental +c 18 2:1 xtup +c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. +c 20 Set on last note of each seg except last seg of single-slope beam. +c 21 Set on 1st note of each seg except 1st seg of single-slope beam. +c 22-26 If .ne.0, printed xtup number for xtup starting on this note. +c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase +c multiplicity by 1 +c 28 Set on main note of chord if accidentals are ordered. +c 29 Tag for chordal accidental shift...means add to autoshifts. +c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. +c If upstem|downstem, main is upper|lower member of 2nd +c Action is to interchange pitches only when notes are placed. +ccccccccccccc +cc mult cc +ccccccccccccc +c 0-3 Multiplicity+8 (mult= # of flags) +c 4 Set if slope adjustment for xtup bracket +c 5-9 16+slope adjustment +c 27 Stemlength override +c 28-30 New stem length. +ccccccccccccc +cc isdat1 cc +ccccccccccccc +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +ccccccccccccc +cc isdat2 cc +ccccccccccccc +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted slur +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +ccccccccccccc +cc isdat3 cc +ccccccccccccc +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +ccccccccccccc +cc isdat4 cc Set these all at turn-on using s option +ccccccccccccc +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +ccccccccccccc +c icrdat c +ccccccccccccc +c 0-7 ip within voice +c 8-11 ivx (together with 28th bit) +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Flag for cautionary accidental on chord note +ccccccccccccc +c icrdot c: +ccccccccccccc +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c +cccccccccccccccccccccccccccccccc + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk, + * isfig,rptnd1,rptprev + logical loop,lastchar,slint,svolta,evolta,onvolt, + * cwrest(nm),islast,inlast,optimize + integer istop(80),numbms(nm),istart(80) + real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks), + * tstart(80),squez(80) + character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq + character*79 notexq,inameq + character*40 pathnameq + character*44 basenameq + character*24 fmtq + character*20 voltxtq + character*120 instrq,titleq,compoq + common /comlast/ islast,usevshrink + logical usevshrink,stickyS,OptLineBreakTies,autofbon + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /comstart/ facmtr + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /combeam/ ibmtyp + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comas3/ ask(2500),iask,topmods + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2, + * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq,lnholdq + logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend, + * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb, + * btest,sluron,setis,nobar1 + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /compoi/ ispoi + common /combc/ bcspec + common /comeon/ eonk,ewmxk + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comhsp/ hpttot(176) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /commus/ musize,whead20 + common /comtol/ tol + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize, + * ismbr,putmbr + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comcb/ nbc,ibcdata(36) + common /comclefq/ clefq + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /combibarcnt/ ibarcnt + if (.not.optimize) then + print* + print*,'Starting second PMX pass' + print* + write(15,'(a)')'Starting second PMX pass' + end if + ncalls = ncalls+1 + islast = inlast + macuse = 0 + isyscnt = 0 + stemmax = 8.2 + stemmin = 3.9 + stemlen = 6.0 + sq = chax(92) + bcspec = .true. + topmods = .false. + ismbr = .false. + read(12,'(a)')basenameq + read(12,*)lbase + read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop, + * etabot,inbothd,inhnoh,isig + ilbuf = 1 + ipbuf = 0 + call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0, + * npages,nsyst,musicsize,fracindent,istype0,inameq, + * clefq,sepsymq,pathnameq,lpath,isig0) + if (ismidi) then +c +c Initial key signature and meter for pickup bar +c + call midievent('k',isig,0) + if (xmtrnum0 .gt. tol) then +c +c We have a pickup. Some tricky stuff to get a meter: +c + xntrial = xmtrnum0 + do 5 ip2 = 0 , 5 + if (abs(mod(xntrial,1.)) .lt. tol) go to 6 + xntrial = xntrial*2 +5 continue + print*,'Problem finding meter for pickup bar' + xntrial = 1. + ip2 = 0 +6 continue + call midievent('m',nint(xntrial),2**ip2*mtrdenl) + else +c +c No pickup, enter the starting meter +c + call midievent('m',mtrnuml,mtrdenl) + end if + end if +c +c Set musicsize from value passed in common, due to possible reset by S[n]m16 +c + musicsize = musize + read(12,*)npages,widthpt,height,hoffpt,voffpt,nsyst, + * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto +c +c If default width ever changes, must adjust this stmt. +c + slfac1 = 0.00569*524./widthpt + figbass = .false. + read(13,*)ifig + if (ifig .eq. 1) then + figbass = .true. + open(14,status='SCRATCH') + write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq// + * 'sysno by 1'//sq//'ifcase'//sq//'sysno%' + end if + lastchar = .false. + ibcoff = 0 + if (xmtrnum0 .gt. 0.) ibcoff = -1 + open(11,status='SCRATCH') +c +c vshrink for the first page is calculated in topfile, +c and if true set interstaff=10. vshrink affects Titles. +c Must also save vshrink for page ending. +c + call topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur) +c +c ninow is working value of # of instruments. noinst is max #, and # at start. +c + ninow = noinst +c +c Save original printed meter in case movement breaks +c + movnmp = mtrnmp + movdnp = mtrdnp +c + if (islast .and. figbass .and. musicsize.eq.16) + * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%' +c + if (islast .and. isligfont) then + if (musicsize .eq. 16) then + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%' + else + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%' + end if + end if + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenb1 = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenb1 = lenb1*2 + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + lenb0 = nint(xmtrnum0*lenbeat) + if (mtrdenl .eq. 2) lenb0 = lenb0*2 + if (lenb0 .ne. 0) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1' + lenbar = lenb0 + else + lenbar = lenb1 + end if +c +c Initialize full-program variables +c + fixednew = 0. + scaldold = 0. + fintstf = -1. + gintstf = 1. + nasksys = 0 + ibarcnt = 0 + iline = 0 + movbrk = 0 + isystpg = 0 + ipage = 1 + iccount = 128 + iask = 0 + nhstot = 0 + nb = 1 + if (.not.optimize) jprntb = 81 + idsig = 0 +c +c Next 5 are raise-barno parameters. irzbnd is integer part of default level. +c + irzbnd = 3 + if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4 + is1n1 = 0 + isnx = 0 + SlurCurve = 0. +c +c 111109 Made global rather than per gulp +c + ndyn = 0 + ispoi = .false. + slint = .false. + lrptpend = .false. + rptnd1 = .false. + rptfq2 = 'E' + rptprev = .false. + onvolt = .false. + flgndb = .false. + fbon = .false. + shifton = .false. + ornrpt = .false. + setis = .false. + lowdot = .false. + rename = .false. + nobar1 = .false. + equalize = .false. + usevshrink = .true. + WrotePsslurDefaults = .false. + OptLineBreakTies = .false. + HeaderSpecial = .false. +c +c vshrink is initialized in topfile +c + stickyS = .false. +c +c ixrest = 1 or 2 if xtup has started with a rest +c + do 1 ivx = 1 , nm + ixrest(ivx) = 0 + fullsize(ivx) = 1. +c +c Set legacy note level to middle c as default +c + ndlev(ivx,1) = 29 + ndlev(ivx,2) = 29 +1 continue + npreslur = 0 + nhssys = 0 + listslur = 0 + do 31 i = 1 , 202 + isdat1(i) = 0 + isdat2(i) = 0 +31 continue + nsdat = 0 +c +c Initialize flag for figures in any other voice than 1 +c + ivxfig2 = 0 +c +c Initialize for loop over gulps +c + firstgulp = .true. +c +c Start a gulp +c +30 loop = .true. + notcrd = .true. + isbjmp = .false. + isbj2 = .false. + autofbon = .false. + tautofb = 0. + nbars = 0 + nfigs(1) = 0 + nfigs(2) = 0 + ngrace = 0 + ntrill = 0 + ncrd = 0 + nudorn = 0 + nlit = 0 + nvolt = 0 + ibarmbr = 0 + nudsp = 0 +c ndyn = 0 ! 111109 + ntxtdyn = 0 + nbc = 0 + NumArpShift = 0 + do 3 i = 1 , 37 + graspace(i) = 0. +3 continue +c +c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. +c and also if nv increases in an 'M' directive. +c + do 4 iv = 1 , nv + call newvoice(iv,clefq(iv),.false.) +4 continue +c +c Check if endsymbol was set earlier +c + if (rptnd1) then + rptnd1 = .false. + rptfq2 = rptfq1 + else +c +c Only use if movbrk>0, to signal default ('RD') +c + rptfq2 = 'E' + end if + iv = 1 + ivx = 1 +2 if (loop) then +c +c Within this loop, nv voices are filled up for the duration of the block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). +c nbars is for this input block. +c Only at the beginning of an input block will there be a possible mtr change, +c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) +c + call getnote(loop) + if (lastchar) go to 40 + go to 2 + end if +c +c Finished an input block (gulp). +c + if (ismidi) then +c +c Put rests into midi array for 2nd lines that were not used in this gulp. +c + do 60 iv = 1 , nv + if (twoline(iv) .and. nvmx(iv).eq.1) then + if (firstgulp .and. lenb0.ne.0) then + call addmidi(midchan(iv,2),0,0,0, + * (nbars-1.)*lenbar+lenb0,.true.,.false.) + else + call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true., + * .false.) + end if + end if +60 continue + end if + nvolt = 0 + do 28 iv = 1 , nm + nudoff(iv) = 0 + ndotmv(iv) = 0 +28 continue +c +c Put stuff at top of p.1. Must wait until now to have read title info. +c + if (ibarcnt .eq. 0) then + call puttitle(inhnoh,xnsttop(ipage), + * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 + bar1syst = ibarcnt .eq. iauto + ndig = max(0,int(log10(.001+ibarcnt+ibcoff))) + if (islast) + * write(11,'(a11,i'//chax(50+ndig)//')') + * '% Bar count',ibarcnt+ibcoff + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb) + else + if (.not.optimize) then + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + jprntb = 0 + end if + ibcoff = ibcoff+mbrest-1 + if (ibar.eq.1 .and. firstgulp .and. + * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize +c +c The above may be he only case where the space-before option is used in \mbrest +c + end if +c +c Move the read to after end-of-bar hardspace checks, so we get right poenom +c at end of a line. +c if (bar1syst) read(12,*) poenom +c +c Check for clef at start of bar. No slide yet. Also flags at end of prev. +c bar. This block is run at the start of every bar. May fail for flag at +c end of last bar. To account for necc. hardspaces, compute and store +c nhssys = # of hard spaces for this system +c hesk(nhssys) = elemskips avialable +c hpts(nhssys) = hard points needed, including notehead +c Here, merely insert placeholder into output. Later, when poe is computed, +c compute additional pts and store them in hpttot(1...nhstot). Finally in +c subroutine askfig, write true pts where placeholders are. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(1,ibar-1) + clchb = btest(islur(1,ioff+1),15) + putmbr = .false. + if (ismbr) then + if (clchb) then +c +c Clef change and multi-bar rest coming up. Kluge to get space at end of rest. +c + write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest' + * //sq//'def'//sq//'mbrest#1#2#3{%' + write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55, + * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%' + end if + ismbr = .false. + putmbr = .true. + end if + if (ibar .eq. ibarmbr) ismbr = .true. +c +c Set flag here so at start of next bar, if there's a clef change, can add space +c after the mbr with the above kluge +c + if (.not.(clchb .or. flgndb)) go to 23 +c +c Must check available space +c + ptsndb = 0. +c +c Zero out block signal +c + if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15) +c +c In this loop, we determine how much hardspace is needed (if any) +c 9/7/97 Note that for last bar in input block, if number of lines of +c music decreases in new block, highest numbered ones won't be checked +c since the loop below covers the new nvmx(iv), not necessarily the old +c one. +c 4/18/98 Apparently nmxsav was a solution to the above problem +c + do 16 iv = 1 , nv + do 16 kv = 1 , nvmxsav(iv) + ivx = ivmxsav(iv,kv) + ptsndv = flgndv(ivx)*wheadpt + ioff = 0 + if (ibar .gt. 1) then + ioff = nib(ivx,ibar-1) + ip = ioff + if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2) +c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) + prevtn(ivx) = tnote(ipl2(ivx,ip)) +c +c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. +c + end if +c +c Only allow clef changes when ivx <= nv +c + if (ivx .le. nv) then + clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11) + if (clchv(iv)) then +c +c Clef change in this voice. Turn off signal. Get space avail. +c + islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11) + if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv = + * ptsndv+clefend*wheadpt + end if + end if + ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac) +16 continue +c +c ???? where is nb set??? nb probably in left over from makeabar +c + esk = feon(space(nb)*squez(nb)) + ptsdflt = esk*poenom-wheadpt +c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then + if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0 + * .and. .not.putmbr) then +c +c Must ADD hardspace! So put in a placeholder, and store params for later. +c + if (islast) write(11,'(a)')sq//'xardspace{ pt}%' + nhssys = nhssys+1 + if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then + hesk(nhssys) = esk + hpts(nhssys) = ptsndb+wheadpt + else + hesk(nhssys) = eskgnd + hpts(nhssys) = ptsgnd+wheadpt + end if + fixednew = fixednew+hpts(nhssys) + scaldold = scaldold+hesk(nhssys) + end if + if (clchb) then + do 17 iv = 1 , nv + if (clchv(iv)) then + notexq = sq//'znotes' + lnote = 7 + do 24 iiv = 2 , iv + notexq = notexq(1:lnote)//sepsymq(iiv-1) + lnote = lnote+1 +24 continue +c +c Recompute ioff since it will vary from voice to voice +c + if (ibar .eq. 1) then + ioff = 0 + else + ioff = nib(iv,ibar-1) + end if +c +c Must call clefsym to get nclef, even if there is a movement break +c + call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef) + if (movbrk.eq.0 .and. + * islast) + * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' + call wsclef(iv,ninow,clefq,nclef) + end if +17 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + end if +23 continue +c +c End of loop for end-of-bar hardspaces and non-movbrk clef symbol. +c + if (bar1syst) then + read(12,*) poenom + end if +c +c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) +c + if (ibar .eq. 1) then + islnow = islur(1,1) + iornqnow = iornq(1,1) + else + islnow = islur(1,nib(1,ibar-1)+1) + iornqnow = iornq(1,nib(1,ibar-1)+1) + end if +c +c Check for R-symbols set at end of prior input block +c + if (movbrk.eq.0 .and. rptfq2.ne.'E') then + if (rptfq2 .eq. 'D') then + islnow = ibset(islnow,26) + else if (rptfq2 .eq. 'r') then + islnow = ibset(islnow,6) + else if (rptfq2 .eq. 'd') then + islnow = ibset(islnow,8) + else if (rptfq2 .eq. 'b') then + islnow = ibset(islnow,25) + else + print* + print*,'Illegal symbol with "R" at end of input block:', + * rptfq2 + call stop1() + end if + rptfq2 = 'E' + end if + if (iand(islnow,352) .ne. 0) then +c +c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set +c + lrpt = btest(islnow,5) + rrpt = btest(islnow,6) + lrptpend = lrpt.and.bar1syst + if (lrpt .and. .not.lrptpend) then + if (rrpt) then + if (islast) write(11,'(a)')sq//'setleftrightrepeat' + fixednew = fixednew+wheadpt*lrrptfac-0.4 + else + if (islast) write(11,'(a)')sq//'setleftrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + end if + else if (rrpt) then + if (islast) write(11,'(a)')sq//'setrightrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + else if (btest(islnow,8)) then + if (islast) write(11,'(a)')sq//'setdoublebar' + fixednew = fixednew+wheadpt*dbarfac-0.4 + end if + else if (btest(islnow,26)) then +c +c doubleBAR +c + if (islast) write(11,'(a)')sq//'setdoubleBAR' + fixednew = fixednew+wheadpt*ddbarfac-0.4 + else if (btest(iornqnow,29)) then +c +c no bar line +c +c-- if (islast) write(11,'(a)')sq//'setzalaligne' +c++ + if (islast) then + if (movbrk .eq. 0) then + write(11,'(a)')sq//'setzalaligne' + else +c +c Encountered "Rz" at start of input block at start of new movement, Must +c use newmovement macro with arg 4 rather than setzalaligne, since former +c already redefines stoppiece. +c + rptfq2 = 'z' + end if + end if +c++ + fixednew = fixednew-0.4 + end if +c +c 1st and 2nd endings +c + svolta = btest(islnow,7) + evolta = btest(islnow,9) + if (evolta) then + if (btest(islnow,10)) then + if (islast) write(11,'(a)')sq//'endvoltabox' + else + if (islast) write(11,'(a)')sq//'endvolta' + end if + onvolt = .false. + end if + if (svolta) then + nvolt = nvolt+1 + lvoltxt = index(voltxtq(nvolt),' ')-1 + if (lvoltxt .eq. 1) then + if (islast) write(11,'(a)')sq//'Setvolta' + * //voltxtq(nvolt)(1:1)//'%' + else + if (islast) write(11,'(a)')sq//'Setvolta'//'{'// + * voltxtq(nvolt)(1:lvoltxt)//'}%' + end if + onvolt = .true. + end if + if (ibar .gt. 1) then + ipnow = nib(1,ibar-1)+1 + else + ipnow = 1 + end if + iplnow = ipl(1,ipnow) + if (bar1syst) then +c +c If listslur>0, then there is at least one slur or tie carried over the break +c + ispstie = .false. + if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0 + * .and. islast) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat, + * ispstie,sepsymq) + iline = iline+1 +c +c End an old system, Start a new system +c + if (iline .ne. 1) then +c +c Not first line. +c Get corrected poe = points/elemskip for *previous* system +c + wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + isyscnt = isyscnt+1 + poevec(isyscnt) = poe +c +c Transfer data for system into global arrays to hold until very end +c + do 9 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) +c +c Only admit negative ask if it was user-defined space, signalled by elask<=0. +c + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +9 continue + do 25 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +25 continue +c +c Reset counters for new system +c + scaldold = 0. + fixednew = 0. + nasksys = 0 + nhssys = 0 + end if +c +c End of if block for first bar of non-first system. Still 1st bar, any system +c + if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%' + isystpg = isystpg+1 +c +c Try moving the next stmt way down, to fix a bug and get \eject printed at +c end of single-system page. +c if (isystpg .eq. nsystp(ipage)) isystpg = 0 + read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk + if (iline .gt. 1) fracindent=frac + if (figbass) then + ifigdr(1,iline) = 4 + ifigdr(2,iline) = 4 + end if + slfac = slfac1*musicsize*elsktot + if (iline .ne. 1) then +c +c For the line just _finished_, put figdrop in separate file. +c + if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)') + * sq//'figdrop=',ifigdr(1,iline-1), + * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%' +c +c Check slurs in top staff for interference w/ barno. Only check when +c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS +c keep track of ons and offs when |isig|<=3. +c + ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1 + isnx = 0 + if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then +c +c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 +c Look for termination in remainder of this input block. If not found, +c just use is1n1. Remember, haven't slid down yet. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1) + do 50 isdat = 1 , nsdat + if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv)) + * .and. .not.btest(isdat1(isdat),11) + * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then +c +c Found slur ending. Just check note height, can't do fine adjustments. +c +c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) + is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19)) + go to 51 + end if +50 continue +c +c If exiting loop normally, did not find end of slur. c'est la vie. +c +51 continue + isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd) + if (isnx .gt. 0) then +c +c AHA! Slur likely to interfere with barno. +c +c Modified 090525 to use \bnrs +c + slint = .true. + fmtq = '(a16,i1,a14)' + if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)' + if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{', + * irzbnd+isnx,'.5'//sq//'internote}%' +c if (islast) then +c if (isnx .le. 9) then +c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' +c else +c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' +c end if +c end if +c + end if + end if + if (movbrk .gt. 0) then +c +c movbrk = 0 +c Move the reset down, so can use movbrk>0 to stop extra meter prints. +c +c New movement. Redefine stoppiece, contpiece. These will be called either +c explicitly or as part of alaligne. +c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. +c This is passed to \newmovement. +c + if (rptfq2 .eq. 'E') rptfq2 = 'D' + indsym = index('Ddrbz',rptfq2)-1 + rptfq2 = 'E' +c +c Also check for Rd or Rr set the normal way +c + if (btest(islnow,8)) then + indsym = 1 + else if (btest(islnow,6)) then + indsym = 2 + end if + if (indsym .lt. 0) then + print* + print*,'Illegal end symbol before "/"' + call stop1() + end if +c +c Check for continuation (no bar number reset) +c + if (islast.and. + * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1' + * //sq//'startbarno'//sq//'barno%' + 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 +c +c Change generalmeter if necessary +c + if (islast) call wgmeter(mtrnmp,mtrdnp) +c +c (Moved all name-writing to getnote, right when 'M' is detected) +c + if (btest(iplnow,28)) then +c +c Key signature at movement break +c + iplnow = ibclr(iplnow,28) + if (isig .gt. 0) then + if (islast) write(11,'(a18,i1,a2)') + * sq//'generalsignature{',isig,'}%' + else + if (islast) write(11,'(a18,i2,a2)') + * sq//'generalsignature{',isig,'}%' + end if + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + end if + if (parmov .ge. -.1) then +c +c Resent paragraph indentation +c + ipi = parmov*widthpt+.1 + if (ipi .lt. 10) then + if (islast) write(11,'(a11,i1,a2)') + * sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + if (islast) + * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + if (islast) + * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + end if + end if + if (isystpg .eq. 1) then +c +c First line on a page (not 1st page, still first bar). Tidy up old page +c then eject. +c +c Removed this 5/13/01 as it was causing double endvoltas. This probably +c is only needed at the end in case there is no endvolta specified. +c if (onvolt) then +cc if (islast) write(11,'(a)')sq//'endvoltabox%' +cc onvolt = .false. +c end if +c +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page. Ugly repeated coding here. +c + mtrnms = mtrnuml + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + mtrnuml = mtrnms + if (movbrk .eq. 0 .and. islast) + * call wgmeter(mtrnmp,mtrdnp) + end if +c +c Key signature change? +c + if (btest(iplnow,28) .and. movbrk.eq.0) then + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)') + * notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-'//sq//'afterruleskip}' + * //sq//'zstoppiece'//sq//'PMXbarnotrue%' + else if (mtrnuml.gt.0 .and. movbrk.eq.0) then +c +c Meter change but no signature change +c + if (islast) + * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'// + * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq// + * 'barnoadd%' + if (islast) + * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'// + * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%' + else + if (islast) write(11,'(a)')sq//'stoppiece%' + end if +c +c This is the key spot when vshrink is used. Value of vshrink here comes from +c just after the prior pagebreak, i.e., it is not affected by "Av" +c that may have been entered at this pagebreak, since that only affects usevshrink. +c So choose page *ending* (with or without \vfill) depending on old vshrink. Then +c check value of usevshrink to reset vshrink if necessary for the new page, where +c we have to set \interstaff and later call puttitle. +c Top of first page needs special treatment. For this we use +c novshrinktop, which was set in g1etnote on the first pass, since on +c second pass, vshrink at top of page one is dealt with in topfile, which is called +c *before* any reading in any "Av" at the top of the first input block. +c + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject%' + else + if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%' + end if + ipage = ipage+1 +c +c Now that page is ejected, compute new vshrink +c + vshrink = xintstaff(ipage).gt.20 .and. usevshrink + if (vshrink) then + xinsnow = 10 + else + xinsnow = xintstaff(ipage) + end if + if (fintstf.gt.0 .and. ipage.gt.1) then + xinsnow = xinsnow*fintstf/gintstf + fintstf = -1. + end if + if (xinsnow .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else if (xinsnow .lt. 99.95) then + fmtq = '(a,f4.1,a)' + else + fmtq = '(a,f5.1,a)' + end if +c +c Vertical spacing parameters, then restart +c + if (islast) write(11,fmtq)sq//'interstaff{',xinsnow, + * '}'//sq//'contpiece' +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a)')sq//'newtimes2%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + end if + end if + end if +c +c If no real titles here, which there probably will never be, make vertical +c space at page top with \titles{...}. headlog=.false.<=>no real titles +c + call puttitle(inhnoh,xnsttop(ipage),etatop, + * sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + else +c +c First bar of system, not a new page, force line break +c + if (btest(iplnow,28)) then +c +c Signature change +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (mtrnuml .ne. 0) then +c +c Meter+sig change, new line, may need mods if movement break here. +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) then + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def' + * 'addspace{-'//sq//'afterruleskip}' +c * //sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + write(11,'(a)')sq//'addspace{-'//sq + * //'afterruleskip}%' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'zchangecontext' + end if + else + if (islast) write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// + * 'addspace{-'//sq//'afterruleskip}' +c * sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'alaligne' + else +c +c New meter, no new sig, end of line, not new page. +c +c \generalmeter{\meterfrac{3}{4}}% +c \xchangecontext\addspace{-\afterruleskip}% +c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% +c \zchangecontext +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) then + write(11,'(a)') + * sq//'let'//sq//'bnat'//sq//'barnoadd' + * //sq//'def'//sq//'barnoadd{'//sq//'empty}%' + write(11,'(a)')sq//'xchangecontext'//sq// + * 'addspace{-'//sq//'afterruleskip}'//sq// + * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'zchangecontext' + end if + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + end if + end if +c +c Modified 090525 to use \bnrs +c + if (slint) then + slint = .false. + if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq// + * 'raisebarno{',irzbnd,'.5'//sq//'internote}%' + end if + movbrk = 0 + end if +c +c Clean up if we squelched bar number reset at movement break +c + if (nobar1) then + if (islast) write(11,'(a)')sq//'startbarno1' + nobar1 = .false. + end if + read(12,*,end=14)iauto +14 continue +c +c We come thru here for the 1st bar of every system, so initialize is1n1 +c + is1n1 = 0 +c +c Brought down from above +c + if (isystpg .eq. nsystp(ipage)) isystpg = 0 +c +c Check for linebreak ties +c + if (ispstie) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + else +c +c Not first bar of system +c + if (btest(iplnow,28)) then +c +c Signature change +c + if (mtrnuml .ne. 0) then +c +c Meter+signature change mid line, assume no movement break +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) call wgmeter(mtrnmp,mtrdnp) + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:18)//'-' + lnote = 19 + end if + if (islast) then + iptemp = 48+abs(isig) + charq = chax(iptemp) + notexq = notexq(1:lnote)//charq//'}%' + lnote = lnote+3 + write(11,'(a)')notexq(1:lnote) + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + write(11,'(a)')sq//'xchangecontext%' + end if + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = (facmtr+naccs*.24)*musicsize + end if + else +c +c Signature change only +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) + * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'// sq//'afterruleskip}%' + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = naccs*.24*musicsize + end if + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'xbar' + else +c +c Change meter midline +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'xbar' + end if + end if + end if + end if +c +c Now that xbar's are written, can put in left-repeats at line beginnings +c + if (lrptpend) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1' + * //sq//'leftrepeat' + lrptpend = .false. + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nolev(ivx,ip) = nolev(ivx,ip+ioff) + nodur(ivx,ip) = nodur(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) + irest(ivx,ip) = irest(ivx,ip+ioff) + islur(ivx,ip) = islur(ivx,ip+ioff) + ipl(ivx,ip) = ipl(ivx,ip+ioff) + iornq(ivx,ip) = iornq(ivx,ip+ioff) + mult(ivx,ip) = mult(ivx,ip+ioff) +c if (ivx.le.2 .and. figbass) +c * isfig(ivx,ip) = isfig(ivx,ip+ioff) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + if (ivx.eq.1) then + isfig(1,ip) = isfig(1,ip+ioff) + else + isfig(2,ip) = isfig(2,ip+ioff) + end if + end if +12 continue + if (ivx.le.nv .and. ncc(iv).gt.1) then + islide = 0 + do 13 icc = 1 , ncc(iv) + if (tcc(iv,icc) .le. lenbar) then +c +c This time will drop <=0 when slid. +c + islide = icc-1 + ncmidcc(iv,1) = ncmidcc(iv,icc) + else + tcc(iv,icc-islide) = tcc(iv,icc)-lenbar + ncmidcc(iv,icc-islide) = ncmidcc(iv,icc) + end if +13 continue + ncc(iv) = ncc(iv)-islide + tcc(iv,1) = 0. + end if +11 continue + do 15 ig = 1 , ngrace + ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1) + if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2) +15 continue + do 21 il = 1 , nlit + iplit(il) = iplit(il)-nib(ivlit(il),ibar-1) + if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2) +21 continue + do 22 it = 1 , ntrill + iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1) + if (ibar .gt. 2) iptrill(it) = + * iptrill(it)+nib(ivtrill(it),ibar-2) +22 continue + do 27 icrd = 1 , ncrd +c ivx = iand(15,ishft(icrdat(icrd),-8)) + ivx = iand(15,ishft(icrdat(icrd),-8)) + * +16*igetbits(icrdat(icrd),1,28) + ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + icrdat(icrd) = iand(not(255),icrdat(icrd)) + icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd)) +27 continue + do 29 iudorn = 1 , nudorn +c ivx = iand(15,ishft(kudorn(iudorn),-8)) + ivx = ivxudorn(iudorn) + ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + kudorn(iudorn) = iand(not(255),kudorn(iudorn)) + kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn)) +29 continue + do 42 idyn = 1 , ndyn + idynd = idyndat(idyn) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10) + ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) +c +c The following construction avoids array bound errors in some compilers +c + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(idynd,8,4,ipnew) + idyndat(idyn) = idynd +42 continue + do 43 itxtdyn = 1 , ntxtdyn + idynd = ivxiptxt(itxtdyn) +c ivx = iand(15,idynd) + ivx = iand(31,idynd) +c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) + ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) +c call setbits(idynd,8,4,ipnew) + call setbits(idynd,8,5,ipnew) + ivxiptxt(itxtdyn) = idynd +43 continue + do 41 isdat = 1 , nsdat + isdata = isdat1(isdat) + ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1) + ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(isdata,8,3,ipnew) + isdat1(isdat) = isdata +41 continue + do 44 ibc = 1 , nbc +c ivx = iand(15,ibcdata(ibc)) + ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(ibcdata(ibc),8,4,ipnew) +44 continue + do 45 iarps = 1 , NumArpShift + IpArpShift(iarps) = + * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1) + if (ibar .gt. 2) then + IpArpShift(iarps) = + * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2) + end if +45 continue +c +c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. +c If there are figs left, it will reset all times relative to start of +c current bar. +c + do 46 ivx = 1 , 2 + if (figbass) then + islide = 0 + do 20 jfig = 1 , nfigs(ivx) + if (itfig(ivx,jfig) .lt. lenbar) then +c +c This figure was already used +c + islide = jfig + else + itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar + figq(ivx,jfig-islide) = figq(ivx,jfig) + itoff(ivx,jfig-islide) = itoff(ivx,jfig) + ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig) + end if +20 continue + nfigs(ivx) = nfigs(ivx)-islide + end if + if (nfigs(2) .eq. 0) go to 47 +46 continue +47 continue + end if +c +c End of sliding down for bars after first in gulp. +c +c The following may not be needed by makeabar, but just in case... +c + if (firstgulp .and. lenb0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenb0 + else + lenbar = lenb1 + end if + end if +c +c Equal line spacing stuff +c + if (equalize .and. bar1syst) then + if (isystpg .eq. 1) then + write(11,'(a)')sq//'starteq%' + else if (isystpg .eq. nsystp(ipage)-1) then + write(11,'(a)')sq//'endeq%' + end if + end if + call make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + call make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) +c +c Hardspace before barline? +c + hardb4 = 0. + do 35 iv = 1 , nv + do 35 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (btest(irest(ivx,nn(ivx)),18)) then + nudoff(ivx) = nudoff(ivx)+1 + hardb4 = max(hardb4,udoff(ivx,nudoff(ivx))) + end if +35 continue + if (hardb4 .gt. 0.) then + if (islast) write(11,'(a11,f5.1,a4)')sq + * //'hardspace{',hardb4,'pt}%' + fixednew = fixednew-hardb4 + end if +10 continue + firstgulp = .false. + lenb0 = 0 + go to 30 +40 close(12) + close(13) + ilbuf = 1 + ipbuf = 0 + wdpt = widthpt + if (iline .eq. 1) wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + poevec(nsyst) = poe + if (.not.islast) then + close(11) + close(16) + if (figbass) close(14) + return + end if + do 19 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +19 continue + do 26 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +26 continue + if (islast .and. + * onvolt) write(11,'(a)')sq//'endvoltabox' + if (rptfq2 .ne. 'E') then +c +c Terminal repeat. Right or double? +c + if (rptfq2 .eq. 'r') then + if (islast) write(11,'(a)')sq//'setrightrepeat' + * //sq//'endpiece' + else if (rptfq2 .eq. 'd') then + if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece' + else if (rptfq2 .eq. 'b') then + if (islast) write(11,'(a)')sq//'endpiece' + else if (rptfq2 .eq. 'z') then + if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece' + else +c else if (rptfq2 .ne. 'D') then + print* + print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + if (islast) write(11,'(a)')sq//'Endpiece' + end if + else + if (islast) write(11,'(a)')sq//'Endpiece' + end if + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + else + if (islast) write(11,'(a)') + * sq//'vfill'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + end if + rewind(11) + if (figbass) then + write(14,'(a9,i2,a10,i2,1x,a5)') + * sq//'figdrop=',ifigdr(1,iline), + * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%' + rewind(14) + end if + call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + if (.not.optimize) then + print* + print*,'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + print*,'Done with second PMX pass.' + write(15,'(/,a)')'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + write(15,'(a)')' Done with second PMX pass. Now run TeX' + end if + return + end + subroutine poestats(nsyst,poe,poebar,devnorm) + parameter (nks=125) +c +c Compute avg. & norm. std. dev. of poe. +c + real*4 poe(nks) + sumx = 0. + sumxx = 0. + do 1 isyst = 1 , nsyst + sumx = sumx+poe(isyst) + sumxx = sumxx+poe(isyst)**2 +1 continue +2 continue + devnorm = sqrt(nsyst*sumxx/sumx**2-1) + poebar = sumx/nsyst + return + end + subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq, + * twooftwo,icashft) +c +c Analyzes chords, data to be used with slurs on chords and plain chords. +c Check for 2nds, shift notes if neccesary. +c ipl(10) chord present +c irest(20) set if any note is right shifted +c irest(27) set if any note is left shifted +c ipl(8|9) left|right shift main note +c icrdat(23|24) ditto chord note +c udq is updown-ness, needed to analyze 2nds. +c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. +c icrdot(icrd)(27-29) sequence order of chord note if accid, top down +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,is2nd,twooftwo + integer*4 kicrd(10),levtabl(88) + character*1 udq + do 11 i = 1 , 88 + levtabl(i) = 0 +11 continue + do 1 icrd1 = 1 , ncrd + ivx1 = iand(15,ishft(icrdat(icrd1),-8)) + * +16*igetbits(icrdat(icrd1),1,28) + ip1 = iand(255,icrdat(icrd1)) + if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2 +1 continue + print* + print*, + * 'Cannot find first chord note in precrd. Send source to Dr. Don!' + call stop1() +2 continue + maxlev = nolevm + minlev = nolevm + levtabl(nolevm) = -1 + is2nd = .false. + naccid = 0 + levmaxacc = -100 + levminacc = 1000 +c +c Check 1st 3 bits of nacc for accid on main note of chord. +c + if (iand(7,nacc) .gt. 0) then + naccid = 1 +c +c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, +c otherwise icrd value for note with accidental. +c + kicrd(1) = 0 + levmaxacc = nolevm + levminacc = nolevm +c +c Start the level-ranking +c + icrdot0 = 1 + end if + do 3 icrd2 = icrd1 , ncrd + nolev = igetbits(icrdat(icrd2),7,12) + levtabl(nolev) = icrd2 + maxlev = max(maxlev,nolev) + minlev = min(minlev,nolev) +c +c Check for accidental +c + if (btest(icrdat(icrd2),19)) then + naccid = naccid+1 + levmaxacc = max(levmaxacc,nolev) + levminacc = min(levminacc,nolev) +c +c Add this icrd to list of values for notes with accid's. +c + kicrd(naccid) = icrd2 + if (.not.btest(nacc,28)) then +c +c Order not forced, so get the level-ranking, top down +c + iorder = 1 + do 12 iaccid = 1 , naccid-1 + if (kicrd(iaccid) .eq. 0) then + if (nolevm .gt. nolev) then + iorder = iorder+1 + else + icrdot0 = icrdot0+1 + end if + else + if (igetbits(icrdat(kicrd(iaccid)),7,12) + * .gt. nolev) then + iorder = iorder+1 + else + iold = igetbits(icrdot(kicrd(iaccid)),3,27) + call setbits(icrdot(kicrd(iaccid)),3,27,iold+1) + end if + end if +12 continue + call setbits(icrdot(icrd2),3,27,iorder) + end if + end if +c +c Exit loop if last note in this chord +c + if (icrd2 .eq. ncrd) go to 4 + if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or. +c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 + * igetbits(icrdat(icrd2+1),4,8) + * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4 +3 continue + print* + print*,'Failed to find last chord note. Send source to Dr. Don!' + call stop1() +4 continue +c +c Now icrd1, icrd2 define range of icrd for this chord. +c +c Bypass autos-shifting if any manual shifts are present +c + if (btest(irest,20) .or. btest(irest,27)) go to 10 +c +c Check for 2nds +c + do 5 ilev = 1 , 87 + if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then +c +c There is at least one 2nd.. +c + if (udq .eq. 'u') then +c +c Upstem. Start with 2nd just found and go up, rt-shifting upper +c member of each pair +c + ile = ilev +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,20) +7 continue + if (levtabl(ile+1) .lt. 0) then +c +c Upstem, & upper member is main so must be rt-shifted. This would move +c stem too, so we rt-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,30) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24) + else +c +c Upper member is chord note, must be rt-shifted +c + icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24) + end if + ile = ile+1 +8 continue + ile = ile+1 + if (ile .lt. 87) then + if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then + go to 7 + else + go to 8 + end if + end if + go to 10 + else +c +c Downstem. Start at top and work down, left-shifting lower member of each pair. +c We know that lowest pair is at (ilev,ilev+1). +c + ile = 88 +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,27) +9 continue + if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then + if (levtabl(ile-1) .lt. 0) then +c ipl = ibset(ipl,8) +c +c Dnstem, & lower member is main so must be left-shifted. This would move +c stem too, so we left-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,31) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23) + else +c +c Lower member is chord note, must be shifted +c + icrdat(levtabl(ile-1)) = + * ibset(icrdat(levtabl(ile-1)),23) + end if + ile = ile-1 + end if + ile = ile-1 + if (ile .ge. ilev+1) go to 9 + go to 10 + end if + end if +5 continue +10 continue +c +c Done with 2nds, now do accid's. Call even if just one, in case left shifts. +c +c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, + if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid, + * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft) + return + end + subroutine printl(string) + character*(*) string +c +c Send string to console and to log file +c + print*,string + write(15,'(a)')string + return + end + subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + logical lowdot,IsArpShift + character*80 soutq + character*79 notexq + character*8 symq(2) + character*1 chax + data symq /'raisearp','arpeggio'/ + +c +c Find which iarp, if any +c + do 1 iarp = 1 , narp + if (abs(tnow-tar(iarp)).lt.tol) go to 2 +1 continue +c +c If here, this is the *first* call for this arp. +c + narp = narp+1 + tar(narp) = tnow+tol*.5 + ivar1(narp) = iv + ipar1(narp) = ip + levar1(narp) = nolev + ncmar1(narp) = ncm + return +2 continue +c +c If here, this is *second* call at this time, iarp points to values from 1st. +c +c Check for shift. Set IsArpShift and iarps +c + do 3 iarps = 1 , NumArpShift + if (IvArpShift(iarps) .eq. ivar1(iarp) .and. + * IpArpShift(iarps) .eq. ipar1(iarp)) then + IsArpShift = .true. + notexq = chax(92)//'loffset{' + write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{' + lnote = 14 + go to 4 + end if +3 continue + IsArpShift = .false. + lnote = 0 +4 continue + if (iv .eq. ivar1(iarp)) then +c +c Arp is in a single staff. +c + levbot = min(levar1(iarp),nolev)-ncm+3 + invert = abs(levar1(iarp)-nolev)+1 + else +c +c Arp covers >1 staff. Lower staff has to be the first, upper is current and +c is where the symbol will be written. +c + levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) + invert = -levbot+4+nolev-ncm +c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' +c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), +c *levbot,nolev,ncm + end if +c +c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote +c + isym = mod(invert,2)+1 + ilvert = (invert+1)/2 + if (levbot .ge. 0 .and. levbot .le. 9) then +c +c Single digit +c + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//chax(48+levbot) + else + notexq = notexq(1:lnote)// + * chax(92)//symq(isym)//chax(48+levbot) + end if + lnote = lnote+10 + else + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//'{' + else + notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{' + end if + lnote = lnote+10 + if (levbot .ge. -9) then +c +c Need two spaces for number +c + write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}' + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}' + lnote = lnote+4 + end if + end if +c if (ilvert .le. 9) then +c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, +c * soutq,lsout) +c else +c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' +c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) +c end if + + if (ilvert .gt. 9) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+ilvert) + lnote = lnote+1 + end if + if (IsArpShift) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) +c +c cancel out the stored time, to permit two arps at same time! +c + tar(iarp) = -1. + return + end + subroutine putast(elask,indxask,outq) + character*129 outq,tag + character*9 fmtq + if (elask .ge. 0.) then + if (elask.lt.0.995) then + lp = 3 + else if (elask .lt. 9.995) then + lp = 4 + else + lp = 5 + end if + write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)' + else + lp = 5 + fmtq = '(a2,f5.1)' + end if +c +c Overwrite as follows: ...xyz*ask *lmnop... -> +c ...xyz*ast{.nn}*lmnop... +c ...xyz*ast{n.nn}*lmnop... +c ...xyz*ast{nn.nn}*lmnop... +c or for negative, ...xyz*ast{-nn.n}*lmnop... + tag = outq(indxask+9:) + write(outq(indxask+3:),fmtq)'t{',elask + outq = outq(1:indxask+4+lp)//'}'//tag + return + end + subroutine putcb(ivx,ip,notexq,lnote) + common /comcb/ nbc,ibcdata(36) + character*79 notexq + logical btest +c ivxip = ivx+16*ip + do 1 ibc = 1 , nbc +c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 +c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) +c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 + ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipbc = igetbits(ibcdata(ibc),8,4) + if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2 +1 continue + call printl('Error in putbc, Call Dr. Don') + stop +2 continue + if (btest(ibcdata(ibc),27)) then + lnote = 8 + notexq = char(92)//'pbreath' + else + lnote = 9 + notexq = char(92)//'pcaesura' + end if + ivshft = igetbits(ibcdata(ibc),6,13) +c?? ivshft = igetbits(ibcdata(ibc),6,13)-32 + if (ivshft .gt. 0) ivshft = ivshft-32 + if (ivshft.lt.0 .or. ivshft.gt.9) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (ivshft .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')ivshft + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')ivshft + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + notexq = notexq(1:lnote)//char(48+ivshft) + lnote = lnote+1 + end if + ihshft = igetbits(ibcdata(ibc),8,19) + if (ihshft .eq. 0) then + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else + hshft = .1*(ihshft-128) +c +c -12.81 ornament on a note, next line is top of manual loop. +c +2 continue +c +c Bit # of last ornament (last of bits 0-21) +cc Bit # of last ornament (last of bits 0-24) + ibit = log2(iand(iornq,4194303)) +c ibit = log2(iand(iornq,33554431)) + iornt = 2**ibit +c +c Begin routine to set height. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c 19-20: >^, 21: ? (with or w/o 16-18) +c +c Do not use beam height for . or _ +c + if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then +c +c Height is set by special beam stuff. +c Do not leave ihorn set, do separately for every ornament +c + ihorn = ihornb(ivx,nornb(ivx)) + if (ulpzq .eq. 'u') ihorn = ihorn-2 +c +c Following flag tells whether to increment nornb when exiting the subroutine. +c + usehornb = .true. + else if (ibit .eq. 14) then +c +c Down fermata. Don't worry about upper chord notes. +c + if (ulpzq .eq. 'l') then + ihorn = min(nolev,ncm-3) + else + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (btest(iornt,13) .or. btest(iornt,0)) then +c +c ( or ) +c + ihorn = nolev + else if (iand(iornt,6144) .gt. 0) then +c +cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info +c NOTE: removed .&_ from special beam treatment. +c Staccato . or tenuto _ Need up-down info +c + if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or. + * (minlev.ne.nolev.and.ulpzq.eq.'u')) then + ihorn = nolev + else if (maxlev .eq. nolev) then + ulpzq = 'u' + ihorn = max(nolev+stemlen,ncm+3.) + else + ulpzq = 'l' + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (iscrd .and. nolev .eq. minlev) then + if (ulpzq .eq. 'l') then + ihorn = min(nolev-3,ncm-6) + else + ihorn = min(nolev-nint(stemlen)-3,ncm-6) + end if + else if (ibit.eq.10 .and. nolev.gt.90) then +c +c Special treatment for fermata on a shifted rest +c + ihorn = ncm+5 + else if (ulpzq.eq.'l') then +c +c (iscrd and nolev=maxlev) or (.not.iscrd) +c + ihorn = max(nolev+stemlen+2,ncm+5.) + else + ihorn = max(nolev+2,ncm+5) + end if + ioff = 0 + iclracc = 0 +c +c Begin routine to set name. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c + if (btest(iornt,2)) then + notexq = sq//'shake' + lnote = 6 + else if (btest(iornt,3)) then + notexq = sq//'mordent' + lnote = 8 + else if (btest(iornt,1)) then + notexq = sq//'mtr' + lnote = 4 + else if (btest(iornt,5)) then + notexq = sq//'xtr' + lnote = 4 + else if (btest(iornt,6)) then + notexq = sq//'ptr' + lnote = 4 + else if (btest(iornt,13)) then + notexq = sq//'rpn' + lnote = 4 + else if (btest(iornt,0)) then + notexq = sq//'lpn' + lnote = 4 + else if (btest(iornt,12)) then + notexq = sq//ulpzq//'st' + lnote = 4 + else if (btest(iornt,11)) then + notexq = sq//ulpzq//'pz' + lnote = 4 + else if (btest(iornt,8)) then + notexq = sq//'upz' + lnote = 4 + ioff = -2 + else if (btest(iornt,9)) then + notexq = sq//'uppz' + lnote = 5 + ioff = -2 + else if (btest(iornt,10)) then + if (nodur .lt. 48) then + notexq = sq//'fermataup' + else + notexq = sq//'Fermataup' + end if + lnote = 10 + ioff = -2 + else if (btest(iornt,14)) then + if (nodur .lt. 48) then + notexq = sq//'fermatadown' + else + notexq = sq//'Fermatadown' + end if + lnote = 12 + else if (btest(iornt,21)) then +c +c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 +c + if (btest(iornq,16)) then + notexq = sq//'qsharp' + lnote = 7 + ioff = 2 + iornq = ibclr(iornq,16) + iclracc = 16 + else if (btest(iornq,17)) then + notexq = sq//'qflat' + lnote = 6 + ioff = 1 + iornq = ibclr(iornq,17) + iclracc = 17 + else if (btest(iornq,18)) then + notexq = sq//'qnat' + lnote = 5 + ioff = 2 + iornq = ibclr(iornq,18) + iclracc = 18 + else + notexq = sq//'qedit' + lnote = 6 + ioff = 0 + end if + else if (btest(iornt,16)) then + notexq = sq//'esharp' + lnote = 7 + ioff = 2 + else if (btest(iornt,17)) then + notexq = sq//'eflat' + lnote = 6 + ioff = 1 + else if (btest(iornt,18)) then + notexq = sq//'enat' + lnote = 5 + ioff = 2 + else if (btest(iornt,19)) then + notexq = sq//'usf' + lnote = 4 + ioff = -2 + else if (btest(iornt,20)) then + notexq = sq//'usfz' + lnote = 5 + ioff = -2 + end if + iudorn = 0 +c +c User-defined level shift of ornament from default? +c + if (btest(iornq,25)) then +c +c Find which (if any) element of kudorn has the shift. +c + do 3 iudorn = 1 , nudorn + if (ibit .lt. 21) then + ibitt = ibit +c +c Could have oes, but not oe? or oes? +c + else if (iclracc .gt. 0) then +c +c Earlier cleared edit. accid, meaning it was oes? +c + ibitt = iclracc+6 + else + ibitt = 21 + end if + ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19) +c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 + if (ibitt .eq. iand(33554431,kudorn(iudorn)) + * .and. ivx.eq.ivxudorn(iudorn)) go to 4 +3 continue +c +c Nothing shifted on this note; exit this if block +c + iudorn = 0 + go to 5 +4 continue + ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32 + if (ibit.eq.19 .and. ioffinc .lt. -7) then +c +c Convert usf to lsf. The reason has to do with positioning being impossile +c for some mysterious reason when you drop \usf below the staff +c + notexq = sq//'lsf' + ioffinc = ioffinc+6 + end if + ioff = ioff+ioffinc + end if +5 continue +c +c Shift level to avoid slur. Conditions are +c 1. There is a slur +c 2. No user-defined orn height shift (btest(iornq,25)) +c 3. upslur (islhgt>0) +c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 +c 5. islhgt+3 >= height already computed. +c + if (.not.btest(iornq,25) .and. + * islhgt.gt.0 .and. iand(iornt,30737).eq.0) + * ioff = ioff+dim(islhgt+3,ihorn ) + call notefq(noteq,lnoten,ihorn+ioff,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) + if (iand(iornt,32896) .gt. 0) then +c +c T-trill or trill w/o "tr" +c + call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote) + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + if (iudorn .gt. 0) then + if (btest(kudorn(iudorn),31)) then +c +c Horizontal shift +c + lform = lfmt1(ornhshft(iudorn)) + write(noteq(1:lform),'(f'//chax(48+lform)//'.1)') + * ornhshft(iudorn) + notexq = sq//'roffset{'//noteq(1:lform)//'}{' + * //notexq(1:lnote)//'}' + lnote = lnote+lform+12 + ornhshft(iudorn) = 0. + kudorn(iudorn) = ibclr(kudorn(iudorn),31) + end if + end if +c +c Zero out the bit for ornament just dealt with. +c + iornq = ibclr(iornq,ibit) + if (lout .eq. 0) then + outq = notexq(1:lnote) + else + outq = outq(1:lout)//notexq(1:lnote) + end if + lout = lout+lnote +c +c Check bits 0-21, go back if any are still set +c + if (iand(iornq,4194303) .gt. 0) go to 2 + if (usehornb) nornb(ivx) = nornb(ivx)+1 + return + end + subroutine putshft(ivx,onoff,soutq,lsout) + parameter (nm=24) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + character*80 soutq,notexq + character*1 sq,chax + logical onoff + sq = chax(92) +c +c Start user-defined offsets X(...): or X(...)S +c + if (onoff) nudoff(ivx) = nudoff(ivx)+1 +c +c Xoff is in pts. Round off to nearest .1. Will use at end of shift. +c + xoff = udoff(ivx,nudoff(ivx)) + xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff) + if (.not.onoff) xoff = -xoff + if (xoff .lt. -9.95) then + ifmt = 5 + else if (xoff.lt.-.95 .or. xoff.gt.9.95) then + ifmt = 4 + else + ifmt = 3 + end if + write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff + call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt, + * soutq,lsout) + return + end + subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc, + * etacs1,nv,vshrink,sepsymq) +c +c Called once per page, at top of page! If vshrink, only called for p.1. +c Actual titles only allowed on p.1. (set by headlog). +c 3/18/01: The above comment is probably bogus...can use Tt on later pages. +c + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + character*127 notexq + character*120 instrq,titleq,compoq + parameter (nm=24) + character*1 sq,sepsymq(nm),chax + logical headlog,vshrink + notexq = sq//'znotes' + lenline = 7 + do 22 iv = 1 , nv-1 + notexq = notexq(1:lenline)//sepsymq(iv) + lenline = lenline+1 +22 continue + notexq = notexq(1:lenline)//sq//'zcharnote{' + lenline = lenline+11 + if (.not.headlog) then + inhead = inhnoh + end if + if (vshrink .and. usevshrink) then + inhead = 16 + end if + ndig = int(alog10(inhead+.01))+1 + write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)// + * ',a10)')inhead,'}{'//sq//'titles{' + lenline = lenline+ndig+10 +c +c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether +c headers are present or not. +c + glueil = xnsttop/etatop + vskil = etatop*glueil + if (vshrink .and. usevshrink) vskil = 2 + call writflot(vskil,notexq,lenline) + if (.not.headlog) then + if (islast) write(11,'(a)')notexq(1:lenline) + * //'}{}{0}{}{0}{}{0}}'//sq//'en%' + else + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + lcq = lenstr(instrq,120) + if (lcq .gt. 0) then + xitil = etait*glueil + if (vshrink .and. usevshrink) xitil = 2 + notexq = notexq(1:lenline)//instrq(1:lcq)//'}{' +c +c Null out instrument once used +c + instrq = ' ' + lenline = lenline+lcq+2 + call writflot(xitil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}%' + notexq = '{' + lenline = 1 + lcq = lenstr(titleq,120) + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//titleq(1:lcq) + lenline = lenline+lcq + else + call printl(' ') + call printl('WARNING') + call printl( + * ' In a title block, you have specified instrument and/or') + call printl( + * ' composer but no title for the piece.') + end if + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + xtcil = etatc*glueil + lcq = lenstr(compoq,120) + if (lcq .eq. 0) xtcil = 2*xtcil + if (vshrink .and. usevshrink) xtcil = 2 + call writflot(xtcil,notexq,lenline) + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//compoq(1:lcq)//'}{' + lenline = lenline+2+lcq +c +c Null out compoq so it does not get written later +c + compoq = ' ' + xcsil = etacs1*glueil + if (vshrink .and. usevshrink) xcsil = 2 + call writflot(xcsil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%' + headlog = .false. + end if + return + end + subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom, + * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum, + * eloff,iup,irest,usexnumt) +c +c Places digit for xtuplet. +c + character*1 chax + character*8 noteq + character*79 notexq + logical btest,usexnumt + if (iflop.ne.0 .and. multb.gt.0) then +c +c Number goes on beam side, move R/L by .5 wheadpt for upper/lower +c + eloff = eloff-0.5*iud*wheadpt/poenom +c +c Number goes on beam side, must use beam parameters to set pos'n +c + nlnum = nolev1+islope/slfac*eloff+iup*(multb+8) + if (multb .ge. 2) nlnum = nlnum+iup + else + nlnum = nint(xnlmid-1+3*iud+iflop*11) + end if + if (.not.btest(islur,31)) then +c +c Only print number when wanted. First check vert, horiz offset +c + if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 + if (btest(irest,7)) eloff = eloff+ + * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom + if (.not.usexnumt) then + notexq = chax(92)//'xnum{' + lnote = 10 + istrtn = 7 + else + notexq = chax(92)//'xnumt{' + lnote = 11 + istrtn = 8 + end if + if (eloff .lt. 0.995) then + write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff + else if (eloff .lt. 9.995) then + write(notexq(istrtn:istrtn+3),'(f4.2)')eloff + else + write(notexq(istrtn:istrtn+4),'(f5.2)')eloff + lnote = lnote+1 + end if + call notefq(noteq,lnoten,nlnum,ncmid) + notexq = notexq(1:lnote)//'}'//noteq(1:lnoten) + lnote = lnote+1+lnoten + if (ntupv .lt. 10) then + write(notexq(lnote+1:lnote+1),'(i1)')ntupv + lnote = lnote+1 + else + notexq = notexq(1:lnote)//'{' + write(notexq(lnote+2:lnote+3),'(i2)')ntupv + notexq = notexq(1:lnote+3)//'}' + lnote = lnote+4 + end if + end if + return + end + subroutine read10(string,lastchar) + parameter (maxblks=4000) + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*(*) string + character*128 lnholdq + logical lastchar + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + if (.not.mplay) then + if (ilbuf .gt. nlbuf) go to 999 + call getbuf(string) + return +999 lastchar = .true. + return + else +c +c Play a macro. Set pointer to first character needed in buffer +c + if (ilmac .eq. il1mac(macnum)) then +c +c Getting first line of macro +c + ip1 = ip1mac(macnum) + iplmac = ip1-ic1mac(macnum) + else if (ilmac .le. il2mac(macnum)) then +c +c Beyond first line of macro. Advance line-start pointer. +c + iplmac = iplmac+lbuf(ilmac-1) + ip1 = iplmac+1 + else +c +c Beyond last line of macro. Terminate it! +c + mplay = .false. + endmac = .true. + return + end if + if (ilmac .eq. il2mac(macnum)) then +c +c Getting last line of macro. +c + ip2 = ip2mac(macnum) + else +c +c Getting line before last line of macro. +c + ip2 = iplmac+lbuf(ilmac) + end if + if (ip2 .ge. ip1) then + string = bufq(ip1:ip2) + else +c +c Kluge for when macro start is on a line by itself +c + string = ' ' + end if + ilmac = ilmac+1 + return + end if + end + function readin(lineq,iccount,nline) +c +c Reads a piece of setup data from file lineq, gets a new lineq from +c file 10 (jobname.pmx) and increments nline if needed, passes over +c comment lines +c + character*128 lineq + character*1 durq,chax +4 if (iccount .eq. 128) then +1 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 1 + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (lineq(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(lineq,iccount,durq) +c +c Remember that getchar increments iccount, then reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin + return + end + subroutine readmeter(lineq,iccount,mtrnum,mtrden) + character*128 lineq + character*1 durq,chax + if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then +c +c No slashes, so use old method +c + call getchar(lineq,iccount,durq) + if (durq .eq. '-') then +c +c Negative numerator is used only to printed; signals vertical slash +c + call getchar(lineq,iccount,durq) + mtrnum = -(ichar(durq)-48) + else if (durq .eq. 'o') then +c +c Numerator is EXACTLY 1 +c + mtrnum = 1 + else + mtrnum = ichar(durq)-48 + if (mtrnum .eq. 1) then +c +c Numerator is >9 +c + call getchar(lineq,iccount,durq) + mtrnum = 10+ichar(durq)-48 + end if + end if + call getchar(lineq,iccount,durq) + if (durq .eq. 'o') then + mtrden = 1 + else + mtrden = ichar(durq)-48 + if (mtrden .eq. 1) then + call getchar(lineq,iccount,durq) + mtrden = 10+ichar(durq)-48 + end if + end if + else +c +c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' +c + iccount = iccount+1 + ns = index(lineq(iccount:128),'/') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum +c +c Reset iccount to start of second integer +c + iccount = iccount+ns +c +c There must be either a slash or a blank at pos'n 2 or 3 +c + ns = index(lineq(iccount:iccount+2),'/') + if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden +c +c Set iccount to last character used +c + iccount = iccount+ns-1 + end if + return + end + subroutine readnum(lineq,iccount,durq,fnum) +c +c This reads a number starting at position iccount. Remember that on exit, +c getchar leaves iccount at the last character retrieved. So must only +c call this routine *after* detecting a number or decimal. +c On exit, durq is next character after end of number. +c + character*128 lineq + character*1 durq,chax + i1 = iccount +1 call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .gt. 0) go to 1 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then + i2 = i2-1 + iccount = iccount-1 + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum + return + end + subroutine setbits(isdata,iwidbit,ishift,ivalue) +c +c Sets iwidbits of isdata, shifted by ishift, to ivalue +c + ibase = 2**iwidbit-1 + if (ivalue.gt.ibase) then + print* + print*,'WARNING in setbits: ivalue > ibase' + write(15,'(/,a)')'WARNING in setbits: ivalue > ibase' + end if + isdata = iand(not(ishft(ibase,ishift)),isdata) + isdata = ior(isdata,ishft(ivalue,ishift)) + return + end + subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1) +c +c The MEAN SQUARE slope algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig + real*4 xelsk(24) + integer ipb(24) + ibc = ibmcnt(ivx) + sumxx = 0. + sumxy = 0. + do 2 inb = 1 , nnb + sumxx = sumxx+xelsk(inb)**2 + sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb)) +2 continue + delta = nnb*sumxx-sumx*sumx + em = (nnb*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*slfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/slfac*sumx)/nnb + nolev1 = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + do 4 inb = 1 , nnb + ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac + ynote = nolev(ivx,ipb(inb)) + smin = min(smin,iul*(ybeam-ynote)) +4 continue + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolev1 = nint(nolev1+iul*deficit) + end if + return + end + subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq, + * ivx,nline) + character*1 charq,durq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,btest + character*128 lnholdq,lineq + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac +c +c Macro action +c + call g1etchar(lineq,iccount,charq) + if (charq.eq.'S' .and. ivx.ne.1) then + print* + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"MS..." only put in parts by scor2prt if in voice #1!') + end if + if (index('RSP ',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "M" (macro)!') + call stop1() + else if (charq .ne. ' ') then +c +c Record or playback a macro. Get the number of the macro. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must input number after "MR","MP", or "MS"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macro number must be followed by a blank!') + call stop1() + end if + if (index('RS',charq ).gt. 0) then +c +c Record or save a macro +c + if (macnum.lt.1 .or. macnum.gt.20) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Macro number not in range 1-20!') + call stop1() +c else if (btest(macuse,macnum)) then +c print* +c print*,'WARNING: Redefining macro # ',macnum + end if + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + else if (charq .eq. 'S') then +c +c Save (Record but don't activate) +c +1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + if (mrecord) then + call getbuf(lineq) + nline = nline+1 + iccount = 0 + go to 1 + end if + iccount = iccount+ndxm+1 + end if + else +c +c Playback the macro +c + if (.not.btest(macuse,macnum)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a macro that has not been recorded!') + call stop1() + end if + icchold = iccount + lnholdq = lineq + iccount = 128 + mplay = .true. + ilmac = il1mac(macnum) + end if + end if + return + end + subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) +c +c Sets last 2 args depending on 1st 2, (logical) num, denom. +c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. +c 1: all duple meters +c 2: triple w/ denom=4, subdivide in groups of 2 8ths +c 3: triple w/ denom=8, subdivide in groups of 3 8ths +c Note that lenbar is set at top or when 'm' symbol is read in getnote +c + if (mtrdenl .eq. 4) then + if (mod(mtrnuml,3) .eq. 0) then + ibmtyp = 2 + ibmrep = mtrnuml/3 + else + ibmtyp = 1 + ibmrep = mtrnuml/2 + end if + else if (mtrdenl .eq. 2) then + ibmtyp = 1 + if (mtrnuml .eq. 3) then + ibmrep = 3 + else + ibmrep = 2*mtrnuml/mtrdenl + end if + else +c +c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 +c + ibmtyp = 3 + ibmrep = mtrnuml/3 + end if +c +c Reset so we don't keep writing new meters +c + mtrnuml = 0 +c +c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter +c + ibmrep = max(ibmrep,1) + return + end + subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest) +c +c The outer combo algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm + common /comeskz2/ eskz2(nm,200) + real*4 slope(800),xelsk(24) + integer ipb(24) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xels11(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + ibc = ibmcnt(ivx) + nxtinbm(ivx) = 0 + n1 = ipl2(ivx,ibm1(ivx,ibc)) +c +c Initialize counters used in this subroutine, and then later during actual +c beam drawing, to count later segments of single-slope beam groups +c + nssb(ivx) = 0 + issb(ivx) = 0 +c +c Set flag for xtup beam starting with rest (no others can start with rest) +c + if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1 +c +c Figure how many elemskips to each note. Use the list, counting only non-rests. +c + eskz0 = eskz(ivx,ibm1(ivx,ibc)) + nnb = 0 + sumx = 0. + sumy = 0. + ipxt1 = 0 + iplast = ibm2(ivx,ibc) + do 2 ip = ibm1(ivx,ibc) , iplast + if (.not.btest(irest(ivx,ip),0)) then + nnb = nnb+1 + ipb(nnb) = ip + xelsk(nnb) = eskz(ivx,ip)-eskz0 + sumx = sumx+xelsk(nnb) + sumy = sumy+nolev(ivx,ipb(nnb)) + if (btest(nacc(ivx,ip),21)) then +c +c This is the starting note of later segment of single-slope beam group +c Temporarily store ip here. +c + nssb(ivx) = nssb(ivx)+1 + lev1ssb(ivx,nssb(ivx)) = nnb + end if + end if +c +c New xtup stuff here. Final object is to get distance from start of xtup +c to number. xtinbm counts xtups in this beam only. mtupv is the printed +c number. ntupv is number of notes in xtup, and is only used to get +c eloff, the distance from start of xtup to the number. +c + if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1 + if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then +c +c Xtup is starting here +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + ipxt1 = ip + if (btest(nacc(ivx,ip),18)) then + ndoub = 1 + else + ndoub = 0 + end if + else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then +c +c Xtup ends here. Set total number of notes in xtup. +c + ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1 +c +c Set printed number for embedded xtup. +c + mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub +c +c Middle note of xtup if ntupv odd, note to left of gap if even. +c + ipxtmid = (ip+ipxt1)/2 + eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) + * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+ + * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid)) + ipxt1 = 0 + end if +2 continue +c +c Reset nxtinbm for use as counter as #'s are posted by putxtn(..) +c + nxtinbm(ivx) = 0 + smed = 0. + if (.not.btest(islur(ivx,ipb(1)),2)) then +c +c No forced 0 slope +c + if (nnb .eq. 1) go to 6 + nsc = 0 + do 5 inb = 1 , nnb-1 + do 5 jnb = inb+1 , nnb + nsc = nsc+1 + slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/ + * (xelsk(jnb)-xelsk(inb)) + if (abs(slope(nsc)) .lt. 1.e-4) then + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + end if +5 continue + if (nsc .eq. 1) then + smed = slope(1) + go to 6 + end if + nscmid = nsc/2+1 + do 7 i = 1 , nscmid + do 7 j = i+1 , nsc + if (slope(j) .lt. slope(i)) then + t = slope(j) + slope(j) = slope(i) + slope(i) = t + end if +7 continue + smed = slope(nscmid) + if (nsc .eq. 2*(nsc/2)) then +c +c Even number of slopes in the list, so median is ambiguous +c + if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then +c +c Lower-numbered one is truly less in absolute value, so use it +c + smed=slope(nscmid-1) + else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then +c +c Two slopes are effectively equal. Take the one with sign of the average +c + sum = 0. + do 1 i = 1 , nsc + sum = sum+slope(i) +1 continue + smed = sign(smed,sum) + end if + end if +6 continue + islope(ivx) = nint(0.5*smed*slfac) + if (iabs(islope(ivx)) .gt. 9) + * islope(ivx) = isign(9,islope(ivx)) + else +c +c Forced horizontal beam +c + islope(ivx) = 0 + end if + beta = (sumy-islope(ivx)/slfac*sumx)/nnb +c +c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use +c as is for placing xtup number and/or bracket, then reset it for start of +c actual beam +c + nolev1(ivx) = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + ssq = 0. + syb = 0. +c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) + yb1 = nolev1(ivx) + * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)) + do 4 inb = 1 , nnb + ybeam = yb1+islope(ivx)*xelsk(inb)/slfac +c * -iul*bmhgt*(mult(ivx,ipb(inb))-1) + * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1) + syb = syb+ybeam + ynote = nolev(ivx,ipb(inb)) + off = ybeam-ynote + if (inb .eq. 1) then + off1 = off + else if (inb .eq. nnb) then + off2 = off + end if + ssq = ssq+off*off + smin = min(smin,iul*off) +4 continue + dnolev = 0. + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolevo = nolev1(ivx) + nolev1(ivx) = nint(nolev1(ivx)+iul*deficit) + dnolev = nolev1(ivx)-nolevo + off1 = off1+dnolev + off2 = off2+dnolev + end if + ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2 + if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. + * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax) + * .and. .not.btest(islur(ivx,ipb(1)),2)) then +c +c The first check is to save trouble of putting xtup's in setbm2. +c The penultimate check is that first and last stems aren't both excessive. +c The last check is that a 0 slope has not been forced +c + call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx)) + end if +c +c Check if beam starts or ends too high or low. +c +c xboff = bmhgt*(mult(ivx,ipb(1))-1) + xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1) + l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0. + xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb) + l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0 + if (l1ng .or. l2ng) then +c +c Need to correct start or stop, also slope +c + if (l1ng) then + nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul) + end if + if (l2ng) then + xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul) + end if +c +c Since one or the other end has changed, need to change slope +c + if (.not.btest(islur(ivx,ipb(1)),2)) + * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb)) + end if + if (nssb(ivx) .gt. 0) then +c +c This is a single-slope beam group. Store start heights for later segs. +c + do 3 issbs = 1 , nssb(ivx) + lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac* + * xelsk(lev1ssb(ivx,issbs)) +3 continue + end if + return + end + subroutine sortpoe(nsyst,poe,ipoe) + parameter (nks=125) + real*4 poe(nks) + integer*4 ipoe(nks) +c +c Initialize ipoe: +c + do 3 iord = 1 , nsyst + ipoe(iord) = iord +3 continue +c +c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will +c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. +c + do 4 io1 = 1 , nsyst-1 + do 5 io2 = io1+1 , nsyst + if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then +c +c Interchange the indices +c + itemp = ipoe(io1) + ipoe(io1) = ipoe(io2) + ipoe(io2) = itemp + end if +5 continue +4 continue + return + end + subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 This subr is called ONLY for postscript slurs. +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 + isdat4(nsdat) = 0 + ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur +c +c Get ID code +c + call getchar(lineq,iccount,durq) + if (index('uldtb+-hfnHps ',durq) .gt. 0) then +c +c Null id. Note for ps slurs, 'H' cannot be an ID +c + iccount = iccount-1 + if (lineq(iccount:iccount) .eq. 't') then + idcode = 1 + else + idcode = 32 + end if + else +c +c Set explicit idcode +c + idcode = ichar(durq) + if (lineq(iccount-1:iccount-1) .eq. 't') then +c +c Make t[ID] look like s[ID]t +c + isdat2(nsdat) = ibset(isdat2(nsdat),3) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. +c + if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then +c +c There's a default curvature tweak +c + icurv1 = nint(SlurCurve)+3 + if (icurv1 .eq. 2) icurv1 = 1 + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + end if +c +c Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (durq .eq. 's') then +c +c Endpoint tweaks for linebreak slurs. +c + call getchar(lineq,iccount,durq) ! Must be +|- +c +c Next is vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32) + if (index('+-',dumq) .gt. 0) then +c +c Also a horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64) + end if + iccount = iccount-1 + ilb12 = 1 + go to 1 + else if (index('fnhH',durq).gt.0) then +c +c Special ps slur curvatures. +c Translate to old \midslur args (1,4,5,6) +c + icurv1 = index('fnxhH',durq) + if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + else if (durq .eq. 'p') then ! Local adjustment + call getchar(lineq,iccount,durq) ! +|- + call getchar(lineq,iccount,dumq) ! s|t +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) + if (durq .eq. '+') then + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),26) + else + isdat2(nsdat) = ibset(isdat2(nsdat),28) + end if + else + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),27) + else + isdat2(nsdat) = ibset(isdat2(nsdat),29) + end if + end if + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 +c +c Get id letter +c + if (lineq(iccount:iccount) .eq. 't') then +c +c Old-style t-slur. Use special idcode = 1 +c + idcode = 1 + else + call getchar(lineq,iccount,durq) + if (index('uldtb+-hf ',durq) .gt. 0) then +c +c Null id +c + idcode = 32 + iccount = iccount-1 + else if (durq.eq.'H') then +c +c Postscript slur, cannot use 'H' as code, must check for 2nd 'H' +c + idcode = 32 + iccount = iccount-1 +c +c There may be another "H", but no need to deal with it yet +c + else +c +c Set explicit idcode +c + idcode = ichar(durq) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (index('fhH',durq) .gt. 0) then +c +c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) +c + icurv1 = 2+index('fhH',durq) + if (icurv1 .eq. 3) then + icurv1 = 1 + else if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) +c +c Must change sign if downslur, but cannot do it now since we don't know +c slur direction for sure. +c + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine stop1() + call exit(1) + end + subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink,fontslur + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*79 inameq + character*44 basenameq + character*24 fmtq + character*5 fbarq + character*1 clefq(nm),sq,chax + common /comstart/ facmtr + logical vshrink,lowdot,rename + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) + sq = chax(92) + vshrink = xinstf1.gt.20. .and. .not.novshrinktop + if (vshrink) then + xinsnow = 10. + else + xinsnow = xinstf1 + end if + if (.not.islast) return + write(11,'(a)')'%%%%%%%%%%%%%%%%%' + write(11,'(a)')'%' + write(11,'(a)')'% '//basenameq(1:lbase)//'.tex' + write(11,'(a)')'%' + write(11,'(a)')'%%%%%%%%%%%%%%%%' + write(11,'(a)')sq//'input musixtex' + write(11,'(a)')sq//'input pmx' +c write(11,'(a)')sq//'input musixmad' +c write(11,'(a)')sq//'input musixxad' + write(11,'(a)') + * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%' + if (.not.fontslur) write(11,'(a)')sq//'input musixps' +c +c Need to input musixmad to permit more slurs. +c + if (musicsize .eq. 20) then + write(11,'(a)')sq//'normalmusicsize%' + else if (musicsize .eq. 16) then + write(11,'(a)')sq//'smallmusicsize%' + else if (musicsize .eq. 24) then + write(11,'(a)')sq//'largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterlargefont}%' + else if (musicsize .eq. 29) then + write(11,'(a)')sq//'Largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterLargefont}%' + end if +c +c Set sizes. Have sizes per staff in isize(.) and noinst per staff in +c nsperi(.) +c + iiv = 1 + do 5 iinst = 1 , noinst + if (isize(iiv) .eq. 1) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'smallvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'smallvalue%' + end if + else if (isize(iiv) .eq. 2) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'tinyvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'tinyvalue%' + end if + end if + iiv = iiv+nsperi(iinst) +5 continue +c +c do 5 iiv = 1 , nv +c if (isize(iiv) .eq. 1) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'smallvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'smallvalue%' +c end if +c else if (isize(iiv) .eq. 2) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'tinyvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' +c end if +c end if +c5 continue +c + write(fbarq,'(f5.3)')fbar + write(11,'(a)')sq//'nopagenumbers' + write(11,'(a)')sq//'tracingstats=2'//sq//'relax' + write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt' + write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)') + * sq//'vsize',int(height+.1),'pt' + if (abs(hoffpt) .gt. 0.1) then + if (hoffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'hoffset',nint(hoffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + end if + end if + if (abs(voffpt) .gt. 0.1) then + if (voffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'voffset',nint(voffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + end if + end if +c +c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if +c 3 sharps and treble clef, to avoid vertical clash with top space g# +c + if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)') + * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}' + if (noinst .lt. 10) then + write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + else + write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + end if + iv = 0 + do 1 iinst = 1 , noinst + nstaves = nsperi(iinst) + if (iinst .lt. 10) then + write(11,'(a)')sq//'setstaffs'//chax(48+iinst) + * //chax(48+nstaves) + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}' + * //chax(48+nstaves) + end if + iv = iv+1 + if (nstaves .eq. 1) then + fmtq = chax(48+numclef(clefq(iv))) + lfmtq = 1 + else + fmtq = '{'//chax(48+numclef(clefq(iv))) + lfmtq = 2 + do 2 k = 2 , nstaves + iv = iv+1 + fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv))) + lfmtq = lfmtq+1 +2 continue + fmtq = fmtq(1:lfmtq)//'}' + lfmtq = lfmtq+1 + end if + if (iinst .lt. 10) then + write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq) + else + write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq) + end if + do 3 lname = 79 , 2 , -1 + if (inameq(iinst)(lname:lname) .ne. ' ') go to 4 +3 continue +4 continue + lnam(iinst) = lname + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst, + * '{'//inameq(iinst)(1:lname)//'}' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst, + * '}{'//inameq(iinst)(1:lname)//'}' + end if +1 continue + write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%' + if (EarlyTransOn) + * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn) + call wgmeter(mtrnmp,mtrdnp) + ipi = nint(fracindent*widthpt) + if (ipi .lt. 10) then + write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip' + * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax' + if (.not.vshrink) then + if (xinstf1 .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' + * //sq//'interstaff{',xinstf1,'}'//sq//'relax' + else + write(11,'(a)')sq//'stafftopmarg0pt'// + * sq//'staffbotmarg5'//sq//'Interligne'//sq// + * 'interstaff{10}'//sq//'relax' + end if + if (nv.eq.1) write(11,'(a)')sq//'nostartrule' + write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}' + if (cstuplet) then + write(11,'(a)')sq//'input tuplet' + * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}' + * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}' + * //sq//'/'//sq//'/}}%' + write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet' + * //sq//'let'//sq//'unbkt'//sq//'downtuplet%' + end if + write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq// + * 'addspace'//sq//'afterruleskip%' + return + end + character*1 function udfq(nolev,ncm) +c +c Slur directions +c + common /combc/ bcspec + logical bcspec + ntest = nolev-ncm + if (ntest.lt.0 .or. + * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then + udfq = 'd' + else + udfq = 'u' + end if + return + end + character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv) +c +c Stem direction for single notes +c + character*1 ulfq + character*1 udqqq + logical btest + if (btest(isl,30)) then +c +c Absolute override +c + if (btest(isl,17)) then + udqqq = 'u' + else + udqqq = 'l' + end if + else if (nvmx .eq. 1) then +c +c Single voice per staff, default +c + udqqq = ulfq(1.*nole,ncm) + else +c +c Multi-voice per staff, 1st is lower, 2nd upper +c + if (ivx .le. nv) then + udqqq = 'l' + else + udqqq = 'u' + end if + end if + udqq = udqqq + return + end + character*1 function ulfq(xnolev,ncm) +c +c Stem directions +c + common /combc/ bcspec + logical bcspec + test = xnolev-ncm + if (test.lt.-.001 .or. + * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then + ulfq = 'u' + else + ulfq = 'l' + end if + return + end + function upcaseq(chq) + character*1 chq,upcaseq,chax + if (ichar(chq).ge.61.and.ichar(chq).lt.122) then + upcaseq = chax(ichar(chq)-32) + else + upcaseq = chq + print*,'Warning, upcaseq was called with improper argument: ' + * //chq + stop + end if + return + end + subroutine wgmeter(mtrnmp,mtrdnp) +c +c Writes meter stuff to file 11, so only called if islast=.true. +c + character*1 sq,chax + if (mtrdnp .eq. 0) return + sq=chax(92) + if (mtrnmp.gt.0 .and. mtrnmp.le.9) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i1,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .ge. 10) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i2,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i2,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .lt. 0) then + write(11,'(a26,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfracS{', + * -mtrnmp,'}{',mtrdnp,'}}%' + else if (mtrdnp .le. 4) then + write(11,'(a21,i1,a2)') + * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%' + else if (mtrdnp .eq. 5) then + write(11,'(a)')sq//'generalmeter'//sq//'allabreve%' + else if (mtrdnp .eq. 6) then + write(11,'(a)')sq//'generalmeter'//sq//'meterC%' + else if (mtrdnp .eq. 7) then + write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%' + end if + return + end + subroutine writemidi(jobname,ljob) + parameter(nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + character*1 byteq(4),char,chax + character*10 tempoq,instq + character*44 jobname + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + logical rename + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) +c +c Used to be icmm(0:nm); did midi fail when nv>16? +c + integer*2 iinsiv(nm),icmm(0:15) + character*5 versionc + common /comver/ versionc +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c Can't remember why these were not consecutive. +c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ +c +c Write Header +c + write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6) + * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240) + if (debugmidi) + * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6, + * 0,1,0,numchan+1,0,240 +c +c Write the "conductor" track, for keys, meter, and tempos +c Get the number of bytes in the conductor event stream +c + ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec) + do 15 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec) +15 continue +c ib1 = (4+ljob+26+ndata+4)/256 +c ib0 = 4+ljob+26+ndata+4-256*ib1 + ib1 = (4+ljob+27+ndata+4)/256 + ib0 = 4+ljob+27+ndata+4-256*ib1 + write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0) +c +c Text header +c +c * //char(0)//char(255)//char(1)//char(ljob+26) + * //char(0)//char(255)//char(1)//char(ljob+27) + if (debugmidi) + * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0, + * 0,255,1,ljob+27 + write(51,'(a,$)')jobname(1:ljob) + if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"' +c +c (separate writes are needed to defeat compiler BUG!!!) +c +c write(51,'(a,$)')'.mid, produced by PMX 2.30' + write(51,'(a,$)')'.mid, produced by PMX '//versionc + if (debugmidi) write(52,'(a)') + * '".mid, produced by PMX '//versionc//'"' +c +c Conductor event data: Loop over sections. +c + do 16 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(numchan,isec) + else + mend = imidi(numchan) + end if + do 17 i = msecstrt(numchan,isec) , mend + write(51,'(a,$)')char(mmidi(numchan,i)) + if (debugmidi) write(52,'(z4)')mmidi(numchan,i) +17 continue +16 continue +c +c And close out the time sig / tempo track. +c + write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 +c +c Loop over track for each voice: The following sets up iv. +c + iv = nv + if (twoline(nv)) then + kv = 2 + else + kv = 1 + end if +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 +c + do 5 icm = 0 , numchan-1 +c +c Get the number of bytes in the data stream +c + ndata = 1+imidi(icm)-msecstrt(icm,nmidsec) + do 11 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec) +11 continue +c +cc Add 3 (for instrum) plus 4 (for closing) to byte count, +c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, +c +c ndata = ndata+7 + ndata = ndata+11 +c +c Add 4+lnam(iinsiv(iv)) if lnam>0 , +c + if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv)) +c +c Separate total byte counts into 4 bytes +c + do 2 ibyte = 1 , 4 + if (ndata .gt. 0) then + byteq(ibyte) = char(mod(ndata,256)) + ndata = ishft(ndata,-8) + else + byteq(ibyte) = char(0) + end if +2 continue +c +c Now write front stuff for this track +c + write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1) + * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) + * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm)) + if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm, + * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)), + * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), + * 0,11*16+icmm(icm),10,midbc(icm) + if (lnam(iinsiv(iv)) .gt. 0) then +c +c Add instrument name as sequence name +c + write(51,'(a,$)')char(0)//char(255)//char(3) + * //char(lnam(iinsiv(iv))) + if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv)) + write(51,'(a,$)') + * inameq(iinsiv(iv))(1:lnam(iinsiv(iv))) + if (debugmidi) write(52,'(a)') + * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"' + end if + write(tempoq,'(i2)')icm + write(instq,'(i3)')midinst(iv) + call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3)) +c +c Notes: Loop over sections. +c + do 9 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(icm,isec) + else + mend = imidi(icm) + end if + do 10 i = msecstrt(icm,isec) , mend + write(51,'(a,$)')char(mmidi(icm,i)) + if (debugmidi) write(52,'(z4)')mmidi(icm,i) +10 continue +9 continue +c +c Closing 4 bytes +c + write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 + if (kv .eq. 2) then + kv = 1 + else if (iv .eq. 1) then + go to 5 + else + iv = iv-1 + if (twoline(iv)) kv=2 + end if +5 continue + write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan) + write(15,'(1x,a12,(10i6))') + * 'Bytes used:',(imidi(icm),icm=0,numchan) + close(51) + if (debugmidi) close(52) + return + end + subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag) + parameter(nm=24) + integer*4 iInstTrans(nm),iTransKey(nm) + character*79 notexq + character*1 chax + logical flag +c +c Assumes notexq is blank +c + do 1 i = 1 , nInstTrans + notexq = chax(92)//'setsign' + lnote = 8 + if (iInstTrans(i) .lt. 10) then + notexq = notexq(1:lnote)//chax(48+iInstTrans(i)) + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iInstTrans(i),'}' + lnote = lnote+4 + end if + if (iTransKey(i) .lt. 0) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iTransKey(i),'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+iTransKey(i)) + lnote = lnote+1 + end if + write(11,'(a)')notexq(1:lnote)//'%' +1 continue + flag = .false. + return + end + subroutine writflot(x,notexq,lenline) + character*(*) notexq + if (x .lt. 0.95) then + write(notexq(lenline+1:lenline+2),'(f2.1)')x + lenline = lenline+2 + else if (x .lt. 9.95) then + write(notexq(lenline+1:lenline+3),'(f3.1)')x + lenline = lenline+3 + else + write(notexq(lenline+1:lenline+4),'(f4.1)')x + lenline = lenline+4 + end if + return + end + subroutine wsclef(iv,ninow,clefq,nclef) +c +c Writes \setclef for instrument containing voice iv +c + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + logical rename + character*1 clefq(nm),chax + character*20 temq + if (nclef .lt. 7) then + clefq(iv) = chax(48+nclef) + else + clefq(iv)='9' + end if + if (.not.islast) return + iv1 = 1 + do 1 iinst = 1 , ninow + if (iv .lt. iv1+nspern(iinst)) go to 2 + iv1 = iv1+nspern(iinst) +1 continue + print* + print*,'Should not be here in wsclef!' + call stop1() +2 continue + iv2 = iv1+nspern(iinst)-1 + if (iinst .lt. 10) then + temq = chax(92)//'setclef'//chax(48+iinst) + ltem = 9 + else + write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}' + ltem = 12 + end if + if (iv1 .eq. iv2) then + write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' + else + temq = temq(1:ltem)//'{' + ltem = ltem+1 + do 3 iiv = iv1 , iv2 + temq = temq(1:ltem)//chax(48+numclef(clefq(iiv))) + ltem = ltem+1 +3 continue + write(11,'(a)')temq(1:ltem)//'}%' + end if + return + end diff --git a/Build/source/utils/pmx/pmx-2.6.18/pmxab.c b/Build/source/utils/pmx/pmx-2.6.18/pmxab.c new file mode 100644 index 00000000000..2f75b2d534a --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/pmxab.c @@ -0,0 +1,37988 @@ +/* -- 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]; +} 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 { + 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 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 { + 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 { + 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 { + 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_b735 = -2.f; +static real c_b736 = 0.f; +static real c_b781 = 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_b1633 = 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] = "19 Mar 12"; + static char version[5] = "2618 "; + 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 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 isys, ljob4; + extern /* Subroutine */ int stop1_(void); + extern integer iargc_(void); + static integer nbari[125], nbars[125], 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; + 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___30 = { 0, 15, 0, 0, 0 }; + static cilist io___34 = { 0, 6, 0, 0, 0 }; + static cilist io___35 = { 0, 15, 0, 0, 0 }; + static cilist io___37 = { 0, 15, 0, 0, 0 }; + static cilist io___46 = { 0, 6, 0, 0, 0 }; + static cilist io___47 = { 0, 15, 0, 0, 0 }; + static cilist io___55 = { 0, 6, 0, 0, 0 }; + static cilist io___56 = { 0, 15, 0, 0, 0 }; + static cilist io___57 = { 0, 6, 0, "(5x,20i3)", 0 }; + static cilist io___58 = { 0, 15, 0, "(5x,20i3)", 0 }; + static cilist io___59 = { 0, 6, 0, 0, 0 }; + static cilist io___60 = { 0, 15, 0, 0, 0 }; + static cilist io___61 = { 0, 6, 0, 0, 0 }; + static cilist io___62 = { 0, 15, 0, 0, 0 }; + static cilist io___63 = { 0, 6, 0, 0, 0 }; + static cilist io___64 = { 0, 15, 0, 0, 0 }; + static cilist io___65 = { 0, 6, 0, "(5x,20i3)", 0 }; + static cilist io___66 = { 0, 15, 0, "(5x,20i3)", 0 }; + static cilist io___67 = { 0, 6, 0, "(5x,20i3)", 0 }; + static cilist io___68 = { 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.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 */ + +/* 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) { + +/* 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]) { + commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.midivel[a1ll_1.iv - 1]; + commvel_1.midbc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.midibal[a1ll_1.iv - 1]; + commvel_1.midtc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.miditran[a1ll_1.iv - 1]; + } + commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.midivel[a1ll_1.iv - 1]; + commvel_1.midbc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.midibal[a1ll_1.iv - 1]; + commvel_1.midtc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.miditran[a1ll_1.iv - 1]; +/* L13: */ + } + } + +/* TEMPORARY!!! */ + + s_wsle(&io___30); + 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___34); + do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39); + e_wsle(); + s_wsle(&io___35); + 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___37); + 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___46); + 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___47); + 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___55); + 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___56); + 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___57); + 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___58); + 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___59); + 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___60); + 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___61); + 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___62); + 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___63); + 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___64); + 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___65); + 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___66); + 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___67); + 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___68); + 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___70 = { 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___70); + 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 */ + extern /* Subroutine */ int stop1_(void); + static integer iudsp; + + /* Fortran I/O blocks */ + static cilist io___72 = { 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___72); + 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 { + +/* 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]) { + --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; + *fixednew += *waskn; + *scaldold += *elaskn; + } + 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 *isig, 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___80 = { 0, 6, 0, 0, 0 }; + static cilist io___92 = { 0, 6, 0, 0, 0 }; + + + +/* 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___80); + 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 (*isig != 0) { + +/* Adjust for signature */ + + *(unsigned char *)notenumq = (char) (*nolev % 7 + 48); + if (*isig >= i_indx("4152630", notenumq, (ftnlen)7, (ftnlen)1) + ) { + ++ipsav; + } else if (-(*isig) >= 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; + +/* Midi transpositions */ + + ipsav += commvel_1.midtc[*icm]; + } + 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___92); + 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___104 = { 0, 11, 0, "(a)", 0 }; + + + if (*lsout + *lnote > 72) { + if (comlast_1.islast) { + s_wsfe(&io___104); +/* 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___112 = { 0, 12, 0, "(a)", 0 }; + static cilist io___113 = { 0, 12, 0, "(a)", 0 }; + static cilist io___115 = { 0, 11, 1, "(a129)", 0 }; + static icilist io___117 = { 0, outq+11, 0, "(f4.1)", 4, 1 }; + static cilist io___120 = { 0, 12, 0, "(a)", 0 }; + static cilist io___121 = { 0, 16, 1, "(a129)", 0 }; + static cilist io___122 = { 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___112); +/* 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___113); +/* 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___115); + 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___117); + 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___120); + 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___121); + 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___122); + 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___124 = { 0, 0, 0, "(a)", 0 }; + static cilist io___129 = { 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___124.ciunit = *iunit; + s_rsfe(&io___124); + 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___129.ciunit = *iunit; + s_wsfe(&io___129); + 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___136 = { 0, 6, 0, 0, 0 }; + static cilist io___137 = { 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___136); + e_wsle(); + s_wsle(&io___137); + 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___175 = { 0, 6, 0, 0, 0 }; + static cilist io___176 = { 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___175); + e_wsle(); + s_wsle(&io___176); + 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]; + integer i__1, i__2, i__3, i__4[3], i__5[2]; + real r__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), pow_ii(integer *, integer *); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + 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 doublereal feon_(real *); + static integer levc, 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 integer nlnum; + 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; + + +/* 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; + 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. */ + + if (multb == 0) { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "qp"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 1) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "ds"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 2) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "qs"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 3) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "hs"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 6, a__1[2] = "hpause"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 7; + } + +/* 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___231 = { 0, 6, 0, 0, 0 }; + static cilist io___232 = { 0, 6, 0, 0, 0 }; + static cilist io___233 = { 0, 6, 0, "(a6,2x,4i8)", 0 }; + + + if (commidi_1.imidi[*icm] >= 24576) { + s_wsle(&io___231); + e_wsle(); + s_wsle(&io___232); + do_lio(&c__9, &c__1, "Midi file is too long! It will be corrupted or" + " worse", (ftnlen)52); + e_wsle(); + s_wsfe(&io___233); + 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 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___268 = { 0, 6, 0, 0, 0 }; + static cilist io___269 = { 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___268); + do_lio(&c__9, &c__1, "Oops2!", (ftnlen)6); + e_wsle(); + stop1_(); + } +/* L5: */ + } + s_wsle(&io___269); + 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___298 = { 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___298); + 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 lnoten, nolevo; + 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___323 = { 0, 6, 0, 0, 0 }; + static cilist io___324 = { 0, 6, 0, 0, 0 }; + + + + + +/* 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_b735, &c_b736, 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___323); + e_wsle(); + s_wsle(&io___324); + 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. */ + +/* call addmidi(midchan(iv,kv),nolevo, */ + i__2 = nolevo - cominsttrans_1.itransamt[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, & + comtop_1.isig, &c_b781, &c_false, &c_false); + } +/* 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___345 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___347 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___348 = { 0, numpq+1, 0, "(i3)", 3, 1 }; + static icilist io___355 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___356 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___357 = { 0, numpq+1, 0, "(i3)", 3, 1 }; + static cilist io___360 = { 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___345); + 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___347); + 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___348); + 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___355); + 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___356); + 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___357); + 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___360); +/* 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, 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___366 = { 0, 6, 0, 0, 0 }; + static cilist io___370 = { 0, 6, 0, 0, 0 }; + static cilist io___371 = { 0, 6, 0, 0, 0 }; + static cilist io___372 = { 0, 15, 0, "(/,a)", 0 }; + static icilist io___375 = { 0, notexq, 0, "(i2)", 2, 1 }; + static cilist io___376 = { 0, 6, 0, 0, 0 }; + static icilist io___400 = { 0, notexq+13, 0, "(a1,f4.1)", 5, 1 }; + static icilist io___402 = { 0, notexq+13, 0, "(f4.1)", 4, 1 }; + static icilist io___404 = { 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___366); + 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 = comask_1.wheadpt * comfig_1.fullsize[*ivx - 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___370); + e_wsle(); + s_wsle(&io___371); + do_lio(&c__9, &c__1, "You defined the twentyfifth slur, one too " + "many!", (ftnlen)47); + e_wsle(); + s_wsfe(&io___372); + 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___375); + 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___376); + 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___400); + 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___402); + 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___404); + 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___418 = { 0, 6, 0, 0, 0 }; + static cilist io___419 = { 0, 6, 0, 0, 0 }; + static cilist io___420 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___428 = { 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 */ + + +/* 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___418); + e_wsle(); + s_wsle(&io___419); + do_lio(&c__9, &c__1, "You1 defined the twentyfifth slur," + " one too many!", (ftnlen)48); + e_wsle(); + s_wsfe(&io___420); + 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)) = nolev */ + comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = + nolevs; + 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___428); + 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 == comslm_1.levson[icm] && (7 & *nacc) == + 0) { + +/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ + + comslm_1.levsoff[icm] = nolevs; + 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 lnoten, nolevt, nolevs; + extern /* Subroutine */ int printl_(char *, ftnlen); + 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___449 = { 0, 6, 0, 0, 0 }; + static cilist io___451 = { 0, 6, 0, 0, 0 }; + static cilist io___452 = { 0, 6, 0, 0, 0 }; + static cilist io___453 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___461 = { 0, 6, 0, 0, 0 }; + + + +/* Called once per main note. (5/26/02) for non-ps slurs only */ + + +/* 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___449); + 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___451); + e_wsle(); + s_wsle(&io___452); + do_lio(&c__9, &c__1, "You1 defined the twenty-fifth slur" + ", one too many!", (ftnlen)49); + e_wsle(); + s_wsfe(&io___453); + 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) { + comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = + nolevs; + 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___461); + 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 == comslm_1.levson[icm] && (7 & *nacc) == + 0) { + +/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ + + comslm_1.levsoff[icm] = nolevs; + 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___471 = { 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___471); + 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___481 = { 0, 6, 0, 0, 0 }; + static cilist io___484 = { 0, 19, 0, "(i6)", 0 }; + static cilist io___488 = { 0, 6, 0, "(1x,a)", 0 }; + static cilist io___489 = { 0, 15, 0, "(a)", 0 }; + static cilist io___492 = { 0, 6, 0, 0, 0 }; + static cilist io___493 = { 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___481); + 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___484); + 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___488); + 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___489); + 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___492); + do_lio(&c__9, &c__1, outq, (ftnlen)78); + e_wsle(); + s_wsfe(&io___493); +/* 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___498 = { 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___498); + 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___532 = { 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___532); + 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_b1633), 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___548 = { 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___548); + 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___558 = { 0, 6, 0, 0, 0 }; + static cilist io___559 = { 0, 6, 0, 0, 0 }; + static cilist io___560 = { 0, 6, 0, 0, 0 }; + static cilist io___561 = { 0, 6, 0, 0, 0 }; + static cilist io___562 = { 0, 15, 0, "(/a)", 0 }; + static cilist io___563 = { 0, 15, 0, "(a11,2x,i3)", 0 }; + static cilist io___564 = { 0, 15, 0, 0, 0 }; + static cilist io___565 = { 0, 6, 0, 0, 0 }; + static cilist io___573 = { 0, 6, 0, 0, 0 }; + static cilist io___574 = { 0, 6, 0, 0, 0 }; + static cilist io___575 = { 0, 6, 0, 0, 0 }; + static cilist io___580 = { 0, 6, 0, 0, 0 }; + static cilist io___581 = { 0, 6, 0, 0, 0 }; + static cilist io___582 = { 0, 6, 0, 0, 0 }; + static cilist io___595 = { 0, 6, 0, 0, 0 }; + static cilist io___598 = { 0, 6, 0, 0, 0 }; + static cilist io___599 = { 0, 6, 0, 0, 0 }; + static cilist io___600 = { 0, 6, 0, 0, 0 }; + static cilist io___603 = { 0, 6, 0, 0, 0 }; + static cilist io___609 = { 0, 6, 0, 0, 0 }; + static cilist io___610 = { 0, 6, 0, 0, 0 }; + static cilist io___611 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___612 = { 0, 6, 0, 0, 0 }; + static cilist io___613 = { 0, 6, 0, 0, 0 }; + static cilist io___614 = { 0, 15, 0, "(a)", 0 }; + static cilist io___615 = { 0, 15, 0, "(a)", 0 }; + static cilist io___623 = { 0, 6, 0, 0, 0 }; + static cilist io___624 = { 0, 6, 0, 0, 0 }; + static cilist io___625 = { 0, 6, 0, 0, 0 }; + static cilist io___626 = { 0, 6, 0, "(1x,a21,i3,a23)", 0 }; + static cilist io___630 = { 0, 6, 0, 0, 0 }; + static cilist io___631 = { 0, 6, 0, 0, 0 }; + static cilist io___632 = { 0, 5, 0, "(a)", 0 }; + static cilist io___636 = { 0, 6, 0, 0, 0 }; + static cilist io___637 = { 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___558); + e_wsle(); + s_wsle(&io___559); + do_lio(&c__9, &c__1, "WARNING:", (ftnlen)8); + e_wsle(); + s_wsle(&io___560); + 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___561); + 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___562); +/* 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___563); + 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___564); + do_lio(&c__9, &c__1, "appending /", (ftnlen)18); + e_wsle(); + s_wsle(&io___565); + 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___573); + e_wsle(); + s_wsle(&io___574); + 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___575); + 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___580); + e_wsle(); + s_wsle(&io___581); + 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___582); + 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___595); + 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___598); + 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___599); + do_lio(&c__9, &c__1, "but it was needed to allow 2-digit" + " height adjustments.", (ftnlen)54); + e_wsle(); + s_wsle(&io___600); + 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___603); + 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___609); + e_wsle(); + s_wsle(&io___610); + do_lio(&c__9, &c__1, "*******WARNING********", (ftnlen)22); + e_wsle(); + s_wsfe(&io___611); + 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___612); + 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___613); + 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___614); + do_fio(&c__1, "This may work in a score, but WILL NOT work i" + "n parts.", (ftnlen)53); + e_wsfe(); + s_wsfe(&io___615); + 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); + 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') { + i__1 = a1ll_2.nv; + 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); + 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#. */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("+-i", 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, "\"K\" (transpose or " + "key change) must be followed by \"+,-,i\"!", (ftnlen) + 128, (ftnlen)58); + stop1_(); + } + 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; + } 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___623); + 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___624); + e_wsle(); + s_wsle(&io___625); + 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___626); + 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___630); + e_wsle(); + s_wsle(&io___631); + 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___632); + 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_; + getmidi_(&a1ll_2.nv, 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___636); + 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___637); + 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___640 = { 0, 6, 0, 0, 0 }; + static cilist io___641 = { 0, 6, 0, "(1x,a46,i3)", 0 }; + static cilist io___642 = { 0, 6, 0, "(a)", 0 }; + static cilist io___645 = { 0, 6, 0, "(a)", 0 }; + static cilist io___646 = { 0, 6, 0, "(a)", 0 }; + static cilist io___647 = { 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___640); + 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___641); + 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___642); + 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___645); + 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); + 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___646); + do_fio(&c__1, "In setup data, fracindent must be <1", (ftnlen)36); + e_wsfe(); + stop1_(); + } + if (*npages > *nsyst) { + s_wsle(&io___647); + 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 *nv, 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); + + /* 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); + + +/* 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') { + +/* Instrument numbers or letters. Expect nv of them. */ + + i__1 = *nv; + 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. */ + + i__1 = *nv; + 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. */ + + i__1 = *nv; + 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 +|-. */ + + i__1 = *nv; + 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); + 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[4], a__2[2], a__3[3], a__4[5], a__5[6], a__6[8], a__7[13]; + integer i__1, i__2, i__3, i__4[4], i__5[2], i__6[3], i__7[5], i__8[6], + i__9[8], i__10[13]; + real r__1; + char ch__1[1], ch__2[11], ch__3[8], ch__4[12], ch__5[10], ch__6[13], + ch__7[1], ch__8[69], ch__9[3], ch__10[9], ch__11[61], 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___697 = { 0, 11, 0, "(a)", 0 }; + static cilist io___705 = { 0, 6, 0, 0, 0 }; + static cilist io___719 = { 0, 6, 0, 0, 0 }; + static cilist io___720 = { 0, 6, 0, 0, 0 }; + static cilist io___725 = { 0, 6, 0, 0, 0 }; + static cilist io___727 = { 0, 6, 0, 0, 0 }; + static cilist io___728 = { 0, 6, 0, 0, 0 }; + static cilist io___731 = { 0, 6, 0, 0, 0 }; + static cilist io___737 = { 0, 11, 0, "(a)", 0 }; + static cilist io___738 = { 0, 11, 0, "(a8,i2,a2)", 0 }; + static cilist io___739 = { 0, 11, 0, "(a)", 0 }; + static cilist io___740 = { 0, 11, 0, "(a)", 0 }; + static cilist io___743 = { 0, 11, 0, "(a)", 0 }; + static cilist io___744 = { 0, 11, 0, "(a)", 0 }; + static cilist io___745 = { 0, 11, 0, "(a11,i2,a)", 0 }; + static cilist io___746 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static cilist io___748 = { 0, 11, 0, "(a8,i1,a3)", 0 }; + static cilist io___749 = { 0, 11, 0, "(a9,i2,a4)", 0 }; + static cilist io___750 = { 0, 11, 0, "(a8,i1,a)", 0 }; + static cilist io___751 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static cilist io___752 = { 0, 6, 0, 0, 0 }; + static cilist io___753 = { 0, 6, 0, 0, 0 }; + static cilist io___766 = { 0, 6, 0, 0, 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, "(a)", 0 }; + static cilist io___771 = { 0, 11, 0, "(a)", 0 }; + static cilist io___773 = { 0, 11, 0, "(a)", 0 }; + static cilist io___776 = { 0, 11, 0, "(a)", 0 }; + static cilist io___777 = { 0, 11, 0, "(a)", 0 }; + static cilist io___778 = { 0, 11, 0, "(a)", 0 }; + static cilist io___779 = { 0, 11, 0, "(a)", 0 }; + static cilist io___780 = { 0, 11, 0, "(a)", 0 }; + static cilist io___781 = { 0, 11, 0, "(a)", 0 }; + static cilist io___782 = { 0, 11, 0, "(a)", 0 }; + static cilist io___783 = { 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___697); + 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___705); + 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___719); + e_wsle(); + s_wsle(&io___720); + 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___725); + 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___727); + e_wsle(); + s_wsle(&io___728); + 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___731); + 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: */ + } + if (comlast_1.islast) { + if (comnotes_1.ninow < 10) { + s_wsfe(&io___737); +/* Writing concatenation */ + i__4[0] = 1, a__1[0] = all_1.sq; + i__4[1] = 7, a__1[1] = "newnoi{"; + i__1 = comnotes_1.ninow + 48; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[2] = 1, a__1[2] = ch__1; + i__4[3] = 2, a__1[3] = "}%"; + s_cat(ch__2, a__1, i__4, &c__4, (ftnlen)11); + do_fio(&c__1, ch__2, (ftnlen)11); + e_wsfe(); + } else { + s_wsfe(&io___738); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 7, a__2[1] = "newnoi{"; + s_cat(ch__3, a__2, i__5, &c__2, (ftnlen)8); + do_fio(&c__1, ch__3, (ftnlen)8); + do_fio(&c__1, (char *)&comnotes_1.ninow, (ftnlen) + sizeof(integer)); + do_fio(&c__1, "}%", (ftnlen)2); + e_wsfe(); + } + } + if (all_1.nv == 1 && nvold > 1) { + if (comlast_1.islast) { + s_wsfe(&io___739); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 11, a__2[1] = "nostartrule"; + s_cat(ch__4, a__2, i__5, &c__2, (ftnlen)12); + do_fio(&c__1, ch__4, (ftnlen)12); + e_wsfe(); + } + } else if (all_1.nv > 1 && nvold == 1) { + if (comlast_1.islast) { + s_wsfe(&io___740); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 9, a__2[1] = "startrule"; + s_cat(ch__5, a__2, i__5, &c__2, (ftnlen)10); + do_fio(&c__1, ch__5, (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__5[0] = 1, a__2[0] = "{"; + 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; + s_cat(hdlndq, a__2, i__5, &c__2, (ftnlen)59); + lclf = 2; + } else if (iis < comnvi_1.nspern[iinow - 1]) { +/* 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; + s_cat(hdlndq, a__2, i__5, &c__2, (ftnlen)59); + ++lclf; + } else { +/* Writing concatenation */ + i__6[0] = lclf, a__3[0] = hdlndq; + i__3 = numclef_(comclefq_1.clefq + (iiv - 1), ( + ftnlen)1) + 48; + chax_(ch__1, (ftnlen)1, &i__3); + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 1, a__3[2] = "}"; + s_cat(hdlndq, a__3, i__6, &c__3, (ftnlen)59); + lclf += 2; + } +/* L61: */ + } + +/* setstaffs & setclef go by instrument, not voice */ + + if (comlast_1.islast) { + if (iinow < 10) { + s_wsfe(&io___743); +/* Writing concatenation */ + i__7[0] = 1, a__4[0] = all_1.sq; + i__7[1] = 9, a__4[1] = "setstaffs"; + i__2 = iinow + 48; + chax_(ch__1, (ftnlen)1, &i__2); + i__7[2] = 1, a__4[2] = ch__1; + i__3 = comnvi_1.nspern[iinow - 1] + 48; + chax_(ch__7, (ftnlen)1, &i__3); + i__7[3] = 1, a__4[3] = ch__7; + i__7[4] = 1, a__4[4] = "%"; + s_cat(ch__6, a__4, i__7, &c__5, (ftnlen)13); + do_fio(&c__1, ch__6, (ftnlen)13); + e_wsfe(); + s_wsfe(&io___744); +/* Writing concatenation */ + i__7[0] = 1, a__4[0] = all_1.sq; + i__7[1] = 7, a__4[1] = "setclef"; + i__2 = iinow + 48; + chax_(ch__1, (ftnlen)1, &i__2); + i__7[2] = 1, a__4[2] = ch__1; + i__7[3] = lclf, a__4[3] = hdlndq; + i__7[4] = 1, a__4[4] = "%"; + s_cat(ch__8, a__4, i__7, &c__5, (ftnlen)69); + do_fio(&c__1, ch__8, lclf + 10); + e_wsfe(); + } else { + s_wsfe(&io___745); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 10, a__2[1] = "setstaffs{"; + s_cat(ch__2, a__2, i__5, &c__2, (ftnlen)11); + do_fio(&c__1, ch__2, (ftnlen)11); + do_fio(&c__1, (char *)&iinow, (ftnlen)sizeof( + integer)); +/* Writing concatenation */ + i__6[0] = 1, a__3[0] = "}"; + i__2 = comnvi_1.nspern[iinow - 1] + 48; + chax_(ch__1, (ftnlen)1, &i__2); + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 1, a__3[2] = "%"; + s_cat(ch__9, a__3, i__6, &c__3, (ftnlen)3); + do_fio(&c__1, ch__9, (ftnlen)3); + e_wsfe(); + s_wsfe(&io___746); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 8, a__2[1] = "setclef{"; + s_cat(ch__10, a__2, i__5, &c__2, (ftnlen)9); + do_fio(&c__1, ch__10, (ftnlen)9); + do_fio(&c__1, (char *)&iinow, (ftnlen)sizeof( + integer)); +/* Writing concatenation */ + i__6[0] = 1, a__3[0] = "}"; + i__6[1] = lclf, a__3[1] = hdlndq; + i__6[2] = 1, a__3[2] = "%"; + s_cat(ch__11, a__3, i__6, &c__3, (ftnlen)61); + do_fio(&c__1, ch__11, 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___748); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 7, a__2[1] = "setname"; + s_cat(ch__3, a__2, i__5, &c__2, (ftnlen)8); + do_fio(&c__1, ch__3, (ftnlen)8); + do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof( + integer)); + do_fio(&c__1, "{}%", (ftnlen)3); + e_wsfe(); + } else { + s_wsfe(&io___749); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 8, a__2[1] = "setname{"; + s_cat(ch__10, a__2, i__5, &c__2, (ftnlen)9); + do_fio(&c__1, ch__10, (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___750); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 7, a__2[1] = "setname"; + s_cat(ch__3, a__2, i__5, &c__2, (ftnlen)8); + do_fio(&c__1, ch__3, (ftnlen)8); + do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof( + integer)); +/* Writing concatenation */ + i__6[0] = 1, a__3[0] = "{"; + i__6[1] = comtop_1.lnam[comnvi_1.iiorig[iinst - 1] + - 1], a__3[1] = comtop_1.inameq + ( + comnvi_1.iiorig[iinst - 1] - 1) * 79; + i__6[2] = 2, a__3[2] = "}%"; + s_cat(ch__12, a__3, i__6, &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___751); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 8, a__2[1] = "setname{"; + s_cat(ch__10, a__2, i__5, &c__2, (ftnlen)9); + do_fio(&c__1, ch__10, (ftnlen)9); + do_fio(&c__1, (char *)&iinst, (ftnlen)sizeof( + integer)); +/* Writing concatenation */ + i__6[0] = 2, a__3[0] = "}{"; + i__6[1] = comtop_1.lnam[comnvi_1.iiorig[iinst - 1] + - 1], a__3[1] = comtop_1.inameq + ( + comnvi_1.iiorig[iinst - 1] - 1) * 79; + i__6[2] = 2, a__3[2] = "}%"; + s_cat(ch__13, a__3, i__6, &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___752); + 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___753); + 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__5[0] = lvoltxt, a__2[0] = comgrace_1.voltxtq + ( + comgrace_1.nvolt - 1) * 20; + i__5[1] = 1, a__2[1] = durq; + s_cat(comgrace_1.voltxtq + (comgrace_1.nvolt - 1) * 20, a__2, + i__5, &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___766); + 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__8[0] = 1, a__5[0] = all_1.sq; + i__8[1] = 3, a__5[1] = "def"; + i__8[2] = 1, a__5[2] = all_1.sq; + i__8[3] = 11, a__5[3] = "atnextline{"; + i__8[4] = 1, a__5[4] = all_1.sq; + i__8[5] = 10, a__5[5] = "toppageno{"; + s_cat(hdlndq, a__5, i__8, &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__6[0] = lhead, a__3[0] = hdlndq; + i__1 = ipg1r + 48; + chax_(ch__1, (ftnlen)1, &i__1); + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 1, a__3[2] = "{"; + s_cat(hdlndq, a__3, i__6, &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___768); +/* Writing concatenation */ + i__5[0] = lhead, a__2[0] = hdlndq; + i__5[1] = 3, a__2[1] = "}}%"; + s_cat(ch__14, a__2, i__5, &c__2, (ftnlen)62); + do_fio(&c__1, ch__14, lhead + 3); + e_wsfe(); + } + } else { + if (comlast_1.islast) { + s_wsfe(&io___769); +/* Writing concatenation */ + i__6[0] = lhead, a__3[0] = hdlndq; + i__6[1] = ltopnam, a__3[1] = comtrans_1.cheadq; + i__6[2] = 3, a__3[2] = "}}%"; + s_cat(ch__15, a__3, i__6, &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___770); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 14, a__2[1] = "relativeaccid%"; + s_cat(ch__16, a__2, i__5, &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___771); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 9, a__2[1] = "bigaccid%"; + s_cat(ch__5, a__2, i__5, &c__2, (ftnlen)10); + do_fio(&c__1, ch__5, (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') { + i__1 = all_1.nv; + 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 { + comfig_1.fullsize[commvl_1.ivx - 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___773); +/* Writing concatenation */ + i__9[0] = 1, a__6[0] = all_1.sq; + i__9[1] = 6, a__6[1] = "global"; + i__9[2] = 1, a__6[2] = all_1.sq; + i__9[3] = 19, a__6[3] = "parskip 0pt plus 12"; + i__9[4] = 1, a__6[4] = all_1.sq; + i__9[5] = 19, a__6[5] = "Interligne minus 99"; + i__9[6] = 1, a__6[6] = all_1.sq; + i__9[7] = 11, a__6[7] = "Interligne%"; + s_cat(ch__17, a__6, i__9, &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__5[0] = lentemp, a__2[0] = tempq; + i__5[1] = 1, a__2[1] = all_1.sepsymq + (iiv - 1); + s_cat(tempq, a__2, i__5, &c__2, (ftnlen)24); + ++lentemp; +/* L51: */ + } + s_wsfe(&io___776); +/* Writing concatenation */ + i__10[0] = 1, a__7[0] = all_1.sq; + i__10[1] = 3, a__7[1] = "def"; + i__10[2] = 1, a__7[2] = all_1.sq; + i__10[3] = 8, a__7[3] = "upstrut{"; + i__10[4] = 1, a__7[4] = all_1.sq; + i__10[5] = 6, a__7[5] = "znotes"; + i__10[6] = lentemp, a__7[6] = tempq; + i__10[7] = 1, a__7[7] = all_1.sq; + i__10[8] = 10, a__7[8] = "zcharnote{"; + i__10[9] = 1, a__7[9] = all_1.sq; + i__10[10] = 9, a__7[10] = "upamt}{~}"; + i__10[11] = 1, a__7[11] = all_1.sq; + i__10[12] = 4, a__7[12] = "en}%"; + s_cat(ch__18, a__7, i__10, &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___777); +/* Writing concatenation */ + i__8[0] = 1, a__5[0] = all_1.sq; + i__8[1] = 12, a__5[1] = "Nosluradjust"; + i__8[2] = 1, a__5[2] = all_1.sq; + i__8[3] = 11, a__5[3] = "Notieadjust"; + i__8[4] = 1, a__5[4] = all_1.sq; + i__8[5] = 10, a__5[5] = "nohalfties"; + s_cat(ch__19, a__5, i__8, &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___778); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 10, a__2[1] = "Sluradjust"; + s_cat(ch__2, a__2, i__5, &c__2, (ftnlen)11); + do_fio(&c__1, ch__2, (ftnlen)11); + e_wsfe(); + } else if (*(unsigned char *)charq == 't') { + s_wsfe(&io___779); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 9, a__2[1] = "Tieadjust"; + s_cat(ch__5, a__2, i__5, &c__2, (ftnlen)10); + do_fio(&c__1, ch__5, (ftnlen)10); + e_wsfe(); + } else if (*(unsigned char *)charq == 'h') { + s_wsfe(&io___780); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 8, a__2[1] = "halfties"; + s_cat(ch__10, a__2, i__5, &c__2, (ftnlen)9); + do_fio(&c__1, ch__10, (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___781); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 12, a__2[1] = "Nosluradjust"; + s_cat(ch__6, a__2, i__5, &c__2, (ftnlen)13); + do_fio(&c__1, ch__6, (ftnlen)13); + e_wsfe(); + } else if (*(unsigned char *)charq == 't') { + s_wsfe(&io___782); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 11, a__2[1] = "Notieadjust"; + s_cat(ch__4, a__2, i__5, &c__2, (ftnlen)12); + do_fio(&c__1, ch__4, (ftnlen)12); + e_wsfe(); + } else if (*(unsigned char *)charq == 'h') { + s_wsfe(&io___783); +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 10, a__2[1] = "nohalfties"; + s_cat(ch__2, a__2, i__5, &c__2, (ftnlen)11); + do_fio(&c__1, ch__2, (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') { + getchar_(lineq, &all_1.iccount, durq, (ftnlen)128, (ftnlen)1); + 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 (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); + } + } 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. */ + + getmidi_(&all_1.nv, 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___795 = { 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 TBD */ + + 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___795); + 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___801 = { 0, 6, 0, 0, 0 }; + static cilist io___802 = { 0, 15, 0, "()", 0 }; + static cilist io___806 = { 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___801); + e_wsle(); + s_wsfe(&io___802); + 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___806); + 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___812 = { 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___812); + 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); + 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___831 = { 0, 6, 0, 0, 0 }; + static cilist io___832 = { 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___831); + e_wsle(); + s_wsle(&io___832); + 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___834 = { 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___834); + 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___835 = { 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___835); + 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_b781) > 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___837 = { 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___837); + 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___859 = { 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___859); + 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___863 = { 0, 6, 0, 0, 0 }; + static cilist io___864 = { 0, 6, 0, 0, 0 }; + static cilist io___865 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___866 = { 0, 11, 0, "(a)", 0 }; + static cilist io___867 = { 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___863); + e_wsle(); + s_wsle(&io___864); + do_lio(&c__9, &c__1, "Merged type-1 TeX strings longer than " + "128 characters", (ftnlen)52); + e_wsle(); + s_wsfe(&io___865); + 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___866); +/* 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___867); +/* 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___912 = { 0, 6, 0, 0, 0 }; + static cilist io___913 = { 0, 6, 0, 0, 0 }; + static cilist io___914 = { 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___912); + e_wsle(); + s_wsle(&io___913); + do_lio(&c__9, &c__1, "Timing problem w/ forced beams", ( + ftnlen)30); + e_wsle(); + s_wsfe(&io___914); + 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 *), i_sign(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; + static integer levother; + 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, kkp; + static real wgr; + static integer iiv; + static real pts; + static logical secondgrace; + extern integer log2_(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 integer indxr; + 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 esksav, taccfac, 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 notefq_(char *, integer *, integer *, integer + *, ftnlen), addmidi_(integer *, integer *, integer *, integer *, + real *, logical *, logical *), dograce_(integer *, integer *, + real *, char *, integer *, integer *, integer *, integer *, + integer *, logical *, logical *, integer *, integer *, integer *, + integer *, integer *, integer *, real *, char *, ftnlen, ftnlen), + 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 real tother; + static integer levtop, iraise1; + static logical isgrace; + static integer icashft; + static real ptbneed; + static integer iraise2, iraise, levbot, 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 levnext, iupdown, ivother, itright, nolevc, ivlast; + static real wheadpt1; + extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) + ; + static integer mtrspc; + + /* Fortran I/O blocks */ + static icilist io___934 = { 0, noteq, 0, "(1H{,i3,1H})", 5, 1 }; + static icilist io___936 = { 0, noteq, 0, "(1H{,i2,1H})", 4, 1 }; + static icilist io___937 = { 0, noteq, 0, "(i1)", 1, 1 }; + static cilist io___940 = { 0, 11, 0, "(a)", 0 }; + static cilist io___941 = { 0, 11, 0, "(a)", 0 }; + static cilist io___944 = { 0, 11, 0, "(a)", 0 }; + static icilist io___947 = { 0, soutq+8, 0, "(f4.1)", 4, 1 }; + static icilist io___948 = { 0, soutq+8, 0, "(f4.2)", 4, 1 }; + static icilist io___949 = { 0, soutq+10, 0, "(i2)", 2, 1 }; + static icilist io___950 = { 0, soutq+11, 0, "(i1)", 1, 1 }; + static cilist io___955 = { 0, 6, 0, 0, 0 }; + static cilist io___956 = { 0, 6, 0, 0, 0 }; + static cilist io___976 = { 0, 6, 0, 0, 0 }; + static cilist io___992 = { 0, 11, 0, "(a)", 0 }; + static cilist io___993 = { 0, 11, 0, "(a)", 0 }; + static cilist io___994 = { 0, 11, 0, "(a)", 0 }; + static cilist io___995 = { 0, 11, 0, "(a)", 0 }; + static cilist io___996 = { 0, 11, 0, "(a)", 0 }; + static cilist io___997 = { 0, 6, 0, 0, 0 }; + static cilist io___998 = { 0, 11, 0, "(a)", 0 }; + static cilist io___999 = { 0, 11, 0, "(a)", 0 }; + static icilist io___1003 = { 0, notexq+11, 0, "(i2)", 2, 1 }; + static icilist io___1009 = { 0, notexq+6, 0, "(f3.1)", 3, 1 }; + static icilist io___1010 = { 0, notexq+6, 0, "(f4.1)", 4, 1 }; + static icilist io___1012 = { 0, notexq+5, 0, "(f3.1)", 3, 1 }; + static icilist io___1013 = { 0, notexq+5, 0, "(f4.1)", 4, 1 }; + static cilist io___1015 = { 0, 6, 0, 0, 0 }; + static cilist io___1016 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1017 = { 0, 11, 0, "(a)", 0 }; + static icilist io___1024 = { 0, notexq, 0, "(f4.2)", 79, 1 }; + static cilist io___1039 = { 0, 6, 0, 0, 0 }; + static cilist io___1052 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1055 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1058 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1060 = { 0, 11, 0, "(a)", 0 }; + + + +/* Factors for grace note, clef spacing. (fraction of wheadpt) */ +/* In 1.04, moved to block data subprogram */ + + + + +/* 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___934); + 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___936); + do_fio(&c__1, (char *)&comgrace_1.noffseg, (ftnlen)sizeof( + integer)); + e_wsfi(); + lnoten = 4; + } else { + s_wsfi(&io___937); + 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___940); +/* 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___941); +/* 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___944); +/* 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___947); + do_fio(&c__1, (char *)&eonsqz, (ftnlen)sizeof(real)); + e_wsfi(); + } else if (eonsqz > .995f) { + s_wsfi(&io___948); + 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___949); + 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___950); + 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___955); + 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___956); + 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. */ + + wheadpt1 = comask_1.wheadpt * comfig_1.fullsize[all_1.iv - 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; + } + } + 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___976); + 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_b736, &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___992); +/* 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___993); +/* 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___994); +/* 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___995); +/* 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___996); +/* 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___997); + 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___998); +/* 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) { + s_wsfe(&io___999); +/* 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___1003); + 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_b736, & + 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___1009); + do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], ( + ftnlen)sizeof(real)); + e_wsfi(); + lnote = 9; + } else { + s_wsfi(&io___1010); + 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___1012); + do_fio(&c__1, (char *)&ptclef[all_1.iv - 1], ( + ftnlen)sizeof(real)); + e_wsfi(); + lnote = 8; + } else { + s_wsfi(&io___1013); + 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___1015); + 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___1016); +/* 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___1017); +/* 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 */ + + 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, (ftnlen)80, (ftnlen)1); + 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 (ismidi) call addmidi(icm,nolev(ivx,ip), */ + if (commidi_1.ismidi) { + i__11 = all_1.nolev[commvl_1.ivx + ip * 24 - 25] - + cominsttrans_1.itransamt[ + 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, &comtop_1.isig, & + all_1.tnote[comipl2_1.ipl2[commvl_1.ivx + ip * + 24 - 25] - 1], &L__1, &c_false); + } + + +/* 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_b735, &c_b736, 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___1024); + 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 { + 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]) { + 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 */ + +/* Get reference level: next following note if no intervening blank rests, */ +/* otherwise next prior note. */ + +/* levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line */ + if (ip != all_1.nn[commvl_1.ivx - 1] && ! + bit_test(all_1.iornq[commvl_1.ivx + ip * + 24 - 1],30)) { + +/* Not the last note and not "look-left" for level */ + + i__11 = all_1.nn[commvl_1.ivx - 1]; + for (kkp = ip + 1; kkp <= i__11; ++kkp) { + if (bit_test(all_1.islur[commvl_1.ivx + + kkp * 24 - 25],29)) { + goto L4; + } + if (! bit_test(all_1.irest[commvl_1.ivx + + kkp * 24 - 25],0)) { + levnext = all_1.nolev[commvl_1.ivx + + kkp * 24 - 25] - ncmid_(& + all_1.iv, &kkp) + 4; +/* Relativ */ + 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 == 1) { + goto L2; + } +/* Get out if this is the first no */ + for (kkp = ip - 1; kkp >= 1; --kkp) { + if (! bit_test(all_1.irest[commvl_1.ivx + kkp + * 24 - 25],0)) { + levnext = all_1.nolev[commvl_1.ivx + kkp * + 24 - 25] - ncmid_(&all_1.iv, & + kkp) + 4; +/* Relative */ + goto L9; + } +/* L3: */ + } + goto L2; +/* Pretty odd, should never be here, but get out */ +L9: + +/* Find note in other voice at same time */ + + i__11 = commvl_1.ivx - all_1.nv - 1; + iupdown = i_sign(&c__1, &i__11); + ivother = commvl_1.ivmx[all_1.iv + (3 - iupdown) / + 2 * 24 - 25]; + tother = 0.f; + i__11 = all_1.nib[ivother + all_1.ibar * 24 - 25]; + for (kkp = 1; kkp <= i__11; ++kkp) { + if ((r__1 = tother - tnow, dabs(r__1)) < + comtol_1.tol) { + goto L6; + } + tother += all_1.nodur[ivother + kkp * 24 - 25] + ; +/* 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(all_1.irest[ivother + kkp * 24 - + 25],0)) { +/* Not a rest, */ + levother = all_1.nolev[ivother + kkp * 24 - + 25] - ncmid_(&all_1.iv, &ip) + 4; + } else { + if (all_1.nodur[ivother + kkp * 24 - 25] == + all_1.nodur[commvl_1.ivx + ip * 24 - + 25]) { + +/* Rest in other voice has same duration, get out (so defualt spacing is used) */ + + goto L2; + } + levother = -iupdown * 50; + } +L7: + indxr = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 + - 25]) + 1; + if (iupdown < 0) { + levtop = comkbdrests_1.levtopr[indxr - 1]; + 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 = comkbdrests_1.levbotr[indxr - 1]; + 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; + } + } + all_1.nolev[commvl_1.ivx + ip * 24 - 25] = iraise + + 100; + } +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___1039); + 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_b736, all_1.ulq, ( + ftnlen)80, (ftnlen)1); + } + +/* 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___1052); +/* 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_b736, all_1.ulq, (ftnlen)80, ( + ftnlen)1); + } +/* 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___1055); + 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___1058); + 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___1060); +/* 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___1084 = { 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___1084); + 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___1085 = { 0, 0, 1, "(a)", 0 }; + static cilist io___1088 = { 0, 0, 0, "(a)", 0 }; + + + *done = FALSE_; + io___1085.ciunit = *iuin; + i__1 = s_rsfe(&io___1085); + 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___1088.ciunit = *iuout; + s_wsfe(&io___1088); + 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___1091 = { 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___1091); + 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___1110 = { 0, noteq, 0, "(i2)", 2, 1 }; + static icilist io___1114 = { 0, numq, 0, "(i2)", 2, 1 }; + static icilist io___1115 = { 0, noteq+1, 0, "(i2)", 2, 1 }; + static icilist io___1116 = { 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___1110); + 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___1114); + 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___1115); + do_fio(&c__1, (char *)&nole, (ftnlen)sizeof(integer)); + e_wsfi(); + lnoten = 3; + } else { + s_wsfi(&io___1116); + 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___1129 = { 0, 6, 0, 0, 0 }; + static cilist io___1130 = { 0, 6, 0, 0, 0 }; + static cilist io___1131 = { 0, 15, 0, "(a)", 0 }; + static cilist io___1132 = { 0, 19, 0, "(i6)", 0 }; + static cilist io___1144 = { 0, 6, 0, 0, 0 }; + static cilist io___1148 = { 0, 6, 0, 0, 0 }; + static cilist io___1154 = { 0, 15, 0, "(/,a20,i4,a1,i4)", 0 }; + static cilist io___1155 = { 0, 6, 0, "(/,a20,i4,a1,i4)", 0 }; + static cilist io___1160 = { 0, 6, 0, 0, 0 }; + static cilist io___1162 = { 0, 6, 0, 0, 0 }; + static cilist io___1163 = { 0, 6, 0, 0, 0 }; + static cilist io___1164 = { 0, 6, 0, 0, 0 }; + static cilist io___1165 = { 0, 15, 0, "(a,2i5)", 0 }; + static cilist io___1166 = { 0, 15, 0, "(a)", 0 }; + static cilist io___1168 = { 0, 12, 0, "(a)", 0 }; + static cilist io___1169 = { 0, 12, 0, 0, 0 }; + static cilist io___1170 = { 0, 12, 0, "(6f10.5/f10.5,3i5)", 0 }; + static cilist io___1171 = { 0, 12, 0, 0, 0 }; + static cilist io___1190 = { 0, 12, 0, 0, 0 }; + static cilist io___1205 = { 0, 12, 0, "(i5)", 0 }; + static cilist io___1223 = { 0, 12, 0, "(1pe12.5/i5,5e12.3)", 0 }; + static cilist io___1224 = { 0, 13, 0, "(i5)", 0 }; + static cilist io___1225 = { 0, 6, 0, "(/,a)", 0 }; + static cilist io___1226 = { 0, 6, 0, 0, 0 }; + static cilist io___1227 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___1228 = { 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___1129); + e_wsle(); + s_wsle(&io___1130); + do_lio(&c__9, &c__1, "Starting first PMX pass", (ftnlen)23); + e_wsle(); + s_wsfe(&io___1131); + 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___1132); + 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___1144); + 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___1148); + 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___1154); + 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___1155); + 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___1160); + 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___1162); + e_wsle(); + s_wsle(&io___1163); + 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___1164); + do_lio(&c__9, &c__1, "There are more systems than bars.", (ftnlen)33); + e_wsle(); + s_wsfe(&io___1165); + 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___1166); + 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___1168); + do_fio(&c__1, basenameq, (*lbase)); + e_wsfe(); + s_wsle(&io___1169); + 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___1170); + 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___1171); + 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___1190); + 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___1205); + 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___1223); + 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___1224); + 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___1225); + do_fio(&c__1, " Done with first pass", (ftnlen)21); + e_wsfe(); + s_wsle(&io___1226); + e_wsle(); + s_wsfe(&io___1227); + do_fio(&c__1, " Done with first pass", (ftnlen)21); + e_wsfe(); + s_wsfe(&io___1228); + 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; + 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 lbit_shift(integer, integer), f_clos(cllist *), f_rew(alist *); + + /* Local variables */ + 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 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 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); + static integer islnow; + extern /* Subroutine */ int 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 lvoltxt, iplnow; + static real xnsttop[40]; + static integer nbarss; + + /* Fortran I/O blocks */ + static cilist io___1229 = { 0, 6, 0, 0, 0 }; + static cilist io___1230 = { 0, 6, 0, 0, 0 }; + static cilist io___1231 = { 0, 6, 0, 0, 0 }; + static cilist io___1232 = { 0, 15, 0, "(a)", 0 }; + static cilist io___1235 = { 0, 12, 0, "(a)", 0 }; + static cilist io___1237 = { 0, 12, 0, 0, 0 }; + static cilist io___1239 = { 0, 12, 0, 0, 0 }; + static cilist io___1255 = { 0, 6, 0, 0, 0 }; + static cilist io___1256 = { 0, 12, 0, 0, 0 }; + static cilist io___1262 = { 0, 13, 0, 0, 0 }; + static cilist io___1264 = { 0, 14, 0, "(a)", 0 }; + static cilist io___1267 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1268 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1269 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1272 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1282 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1284 = { 0, 6, 0, "(/,a20,i4,a1,i4)", 0 }; + static cilist io___1285 = { 0, 15, 0, "(/,a20,i4,a1,i4)", 0 }; + static cilist io___1289 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1290 = { 0, 11, 0, "(a14,f4.1,a)", 0 }; + static cilist io___1299 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1308 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1309 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1310 = { 0, 12, 0, 0, 0 }; + static cilist io___1313 = { 0, 6, 0, 0, 0 }; + static cilist io___1314 = { 0, 6, 0, 0, 0 }; + static cilist io___1317 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1318 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1319 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1320 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1321 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1322 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1325 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1326 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1328 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1329 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1339 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1340 = { 0, 12, 0, 0, 0 }; + static cilist io___1342 = { 0, 14, 0, "(a9,i2,a10,i2,1x,a4)", 0 }; + static cilist io___1345 = { 0, 11, 0, fmtq, 0 }; + static cilist io___1347 = { 0, 6, 0, 0, 0 }; + static cilist io___1348 = { 0, 6, 0, 0, 0 }; + static cilist io___1349 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1350 = { 0, 11, 0, "(a12,2i1,a1)", 0 }; + static cilist io___1351 = { 0, 11, 0, "(a13,i2,a1,i1,a1)", 0 }; + static cilist io___1352 = { 0, 11, 0, "(a18,i1,a2)", 0 }; + static cilist io___1353 = { 0, 11, 0, "(a18,i2,a2)", 0 }; + static cilist io___1355 = { 0, 11, 0, "(a11,i1,a2)", 0 }; + static cilist io___1356 = { 0, 11, 0, "(a11,i2,a2)", 0 }; + static cilist io___1357 = { 0, 11, 0, "(a11,i3,a2)", 0 }; + static cilist io___1359 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1360 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1361 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1362 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1363 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1365 = { 0, 11, 0, fmtq, 0 }; + static cilist io___1366 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1367 = { 0, 11, 0, fmtq, 0 }; + static cilist io___1368 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1369 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1370 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1371 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1372 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1373 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1374 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1375 = { 0, 11, 0, "(a)", 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___1382 = { 0, 11, 0, "(a16,i1,a14)", 0 }; + static cilist io___1383 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1384 = { 0, 12, 1, 0, 0 }; + static cilist io___1387 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1388 = { 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,2i1,a)", 0 }; + static cilist io___1394 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1395 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1411 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1412 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1420 = { 0, 11, 0, "(a11,f5.1,a4)", 0 }; + static cilist io___1421 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1422 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1423 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1424 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1425 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1426 = { 0, 6, 0, 0, 0 }; + static cilist io___1427 = { 0, 6, 0, 0, 0 }; + static cilist io___1428 = { 0, 15, 0, 0, 0 }; + static cilist io___1429 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1430 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1431 = { 0, 11, 0, fmtq, 0 }; + static cilist io___1432 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1433 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1434 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1435 = { 0, 14, 0, "(a9,i2,a10,i2,1x,a5)", 0 }; + static cilist io___1436 = { 0, 6, 0, 0, 0 }; + static cilist io___1437 = { 0, 6, 0, 0, 0 }; + static cilist io___1438 = { 0, 6, 0, 0, 0 }; + static cilist io___1439 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___1440 = { 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___1229); + e_wsle(); + s_wsle(&io___1230); + do_lio(&c__9, &c__1, "Starting second PMX pass", (ftnlen)24); + e_wsle(); + s_wsle(&io___1231); + e_wsle(); + s_wsfe(&io___1232); + 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]; + combc_1.bcspec = TRUE_; + comas3_1.topmods = FALSE_; + ismbr = FALSE_; + s_rsfe(&io___1235); + do_fio(&c__1, basenameq, (ftnlen)44); + e_rsfe(); + s_rsle(&io___1237); + do_lio(&c__3, &c__1, (char *)&lbase, (ftnlen)sizeof(integer)); + e_rsle(); + s_rsle(&io___1239); + 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 */ + + midievent_("k", &comtop_1.isig, &c__0, (ftnlen)1); + 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_b781), dabs(r__1)) < + comtol_1.tol) { + goto L6; + } + xntrial *= 2; +/* L5: */ + } + s_wsle(&io___1255); + 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___1256); + 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___1262); + 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___1264); +/* 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___1267); +/* 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___1268); +/* 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___1269); +/* 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___1272); +/* 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___1282); +/* 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___1284); + 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___1285); + 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___1289); +/* 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___1290); +/* 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___1299); +/* 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___1308); +/* 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___1309); +/* 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___1310); + 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___1313); + e_wsle(); + s_wsle(&io___1314); + 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___1317); +/* 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___1318); +/* 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___1319); +/* 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___1320); +/* 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___1321); +/* 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___1322); +/* 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___1325); +/* 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___1326); +/* 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___1328); +/* 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___1329); +/* 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_b736); + } +/* 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___1339); +/* 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___1340); + 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___1342); +/* 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___1345); +/* 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___1347); + e_wsle(); + s_wsle(&io___1348); + 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___1349); +/* 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(); + } + if (comget_1.movgap < 10) { + if (comlast_1.islast) { + s_wsfe(&io___1350); +/* Writing concatenation */ + i__6[0] = 1, a__4[0] = all_1.sq; + i__6[1] = 11, a__4[1] = "newmovement"; + 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 *)&comget_1.movgap, (ftnlen) + sizeof(integer)); + do_fio(&c__1, (char *)&indsym, (ftnlen)sizeof( + integer)); + do_fio(&c__1, "%", (ftnlen)1); + e_wsfe(); + } + } else { + if (comlast_1.islast) { + s_wsfe(&io___1351); +/* Writing concatenation */ + i__6[0] = 1, a__4[0] = all_1.sq; + i__6[1] = 12, a__4[1] = "newmovement{"; + s_cat(ch__15, a__4, i__6, &c__2, (ftnlen)13); + do_fio(&c__1, ch__15, (ftnlen)13); + 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)); + do_fio(&c__1, "%", (ftnlen)1); + 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___1352); +/* 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___1353); +/* 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___1355); +/* 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___1356); +/* 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___1357); +/* 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___1359); +/* 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___1360); +/* 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___1361); +/* 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___1362); +/* 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___1363); +/* 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___1365); +/* 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___1366); +/* 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___1367); +/* 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___1368); +/* 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___1369); +/* 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___1370); +/* 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___1371); +/* 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); + s_wsfe(&io___1372); +/* 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___1373); +/* 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); + s_wsfe(&io___1374); +/* 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) { + s_wsfe(&io___1375); +/* 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___1376); +/* 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___1377); +/* 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___1378); +/* 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___1379); +/* 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___1380); +/* 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___1381); +/* 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___1382); +/* 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___1383); +/* 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___1384); + 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___1387); + 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); + } + s_wsfe(&io___1388); +/* 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___1390); +/* 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___1391); +/* 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___1392); +/* 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___1393); +/* 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___1394); +/* 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___1395); +/* 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___1411); +/* 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___1412); +/* 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___1420); +/* 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(); + } + 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_b736); + } +/* 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___1421); +/* 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___1422); +/* 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___1423); +/* 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___1424); +/* 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___1425); +/* 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___1426); + e_wsle(); + s_wsle(&io___1427); + 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___1428); + 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___1429); +/* 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___1430); +/* 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___1431); +/* 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___1432); +/* 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___1433); +/* 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___1434); +/* 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___1435); +/* 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___1436); + e_wsle(); + s_wsle(&io___1437); +/* 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___1438); + do_lio(&c__9, &c__1, "Done with second PMX pass.", (ftnlen)26); + e_wsle(); + s_wsfe(&io___1439); +/* 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___1440); + 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___1448 = { 0, 6, 0, 0, 0 }; + static cilist io___1449 = { 0, 6, 0, 0, 0 }; + static cilist io___1460 = { 0, 6, 0, 0, 0 }; + static cilist io___1461 = { 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___1448); + e_wsle(); + s_wsle(&io___1449); + 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___1460); + e_wsle(); + s_wsle(&io___1461); + 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___1464 = { 0, 6, 0, 0, 0 }; + static cilist io___1465 = { 0, 15, 0, "(a)", 0 }; + + + +/* Send string to console and to log file */ + + s_wsle(&io___1464); + do_lio(&c__9, &c__1, string, string_len); + e_wsle(); + s_wsfe(&io___1465); + 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___1471 = { 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___1471); + 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___1479 = { 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___1479); + 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___1491 = { 0, notexq+5, 0, "(f6.2)", 6, 1 }; + static icilist io___1493 = { 0, notexq+5, 0, "(f5.2)", 5, 1 }; + static icilist io___1494 = { 0, notexq+5, 0, "(f4.2)", 4, 1 }; + static icilist io___1495 = { 0, notexq+5, 0, "(f3.2)", 3, 1 }; + static icilist io___1508 = { 0, notexq+5, 0, "(f6.2)", 6, 1 }; + static icilist io___1509 = { 0, notexq+5, 0, "(f5.2)", 5, 1 }; + static icilist io___1510 = { 0, notexq+5, 0, "(f4.2)", 4, 1 }; + static icilist io___1511 = { 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___1491); + 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___1493); + 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___1494); + r__1 = -(*offnsk); + do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real)); + e_wsfi(); + lnote = 9; + } else { + s_wsfi(&io___1495); + 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___1508); + do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real)); + e_wsfi(); + lnote = 11; + } else if (*offnsk < -.995f || *offnsk > 9.995f) { + s_wsfi(&io___1509); + do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real)); + e_wsfi(); + lnote = 10; + } else if (*offnsk < -1e-4f || *offnsk > .995f) { + s_wsfi(&io___1510); + do_fio(&c__1, (char *)&(*offnsk), (ftnlen)sizeof(real)); + e_wsfi(); + lnote = 9; + } else { + s_wsfi(&io___1511); + 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___1539 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1542 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1545 = { 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___1539); +/* 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___1542); +/* 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___1545); +/* 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___1554 = { 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___1554); +/* 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___1560 = { 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___1560); +/* 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___1563 = { 0, 6, 0, 0, 0 }; + static cilist io___1564 = { 0, 6, 0, 0, 0 }; + static cilist io___1565 = { 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___1563); + e_wsle(); + s_wsle(&io___1564); + do_lio(&c__9, &c__1, "WARNING in setbits: ivalue > ibase", (ftnlen)34) + ; + e_wsle(); + s_wsfe(&io___1565); + 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___1578 = { 0, 6, 0, 0, 0 }; + static cilist io___1579 = { 0, 6, 0, 0, 0 }; + static cilist io___1580 = { 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___1578); + e_wsle(); + s_wsle(&io___1579); + e_wsle(); + s_wsle(&io___1580); + 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 slur */ + 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, iiv; + 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___1645 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1646 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1647 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1648 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1649 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1650 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1651 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1652 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1653 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1654 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1655 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1656 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1657 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1658 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1659 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1662 = { 0, 11, 0, "(a8,i1,a)", 0 }; + static cilist io___1663 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static cilist io___1664 = { 0, 11, 0, "(a8,i1,a)", 0 }; + static cilist io___1665 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static icilist io___1667 = { 0, fbarq, 0, "(f5.3)", 5, 1 }; + 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, "(a7,i3,a2)", 0 }; + static cilist io___1671 = { 0, 11, 0, "(a8,i3,a2)", 0 }; + static cilist io___1672 = { 0, 11, 0, "(a8,i2,a2)", 0 }; + static cilist io___1673 = { 0, 11, 0, "(a8,i1,a2)", 0 }; + static cilist io___1674 = { 0, 11, 0, "(a8,i2,a2)", 0 }; + static cilist io___1675 = { 0, 11, 0, "(a8,i3,a2)", 0 }; + static cilist io___1676 = { 0, 11, 0, "(a8,i2,a2)", 0 }; + static cilist io___1677 = { 0, 11, 0, "(a8,i1,a2)", 0 }; + static cilist io___1678 = { 0, 11, 0, "(a8,i2,a2)", 0 }; + static cilist io___1679 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1680 = { 0, 11, 0, "(a19,i1,a1)", 0 }; + static cilist io___1681 = { 0, 11, 0, "(a19,i2,a1)", 0 }; + static cilist io___1684 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1685 = { 0, 11, 0, "(a11,i2,a)", 0 }; + static cilist io___1689 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1690 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static cilist io___1692 = { 0, 11, 0, "(a8,i1,a)", 0 }; + static cilist io___1693 = { 0, 11, 0, "(a9,i2,a)", 0 }; + static cilist io___1694 = { 0, 11, 0, "(a18,i2,a2)", 0 }; + static cilist io___1696 = { 0, 11, 0, "(a11,i1,a2)", 0 }; + static cilist io___1697 = { 0, 11, 0, "(a11,i2,a2)", 0 }; + static cilist io___1698 = { 0, 11, 0, "(a11,i3,a2)", 0 }; + static cilist io___1699 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1700 = { 0, 11, 0, fmtq, 0 }; + static cilist io___1701 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1702 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1703 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1704 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1705 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1706 = { 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___1645); + do_fio(&c__1, "%%%%%%%%%%%%%%%%%", (ftnlen)17); + e_wsfe(); + s_wsfe(&io___1646); + do_fio(&c__1, "%", (ftnlen)1); + e_wsfe(); + s_wsfe(&io___1647); +/* 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___1648); + do_fio(&c__1, "%", (ftnlen)1); + e_wsfe(); + s_wsfe(&io___1649); + do_fio(&c__1, "%%%%%%%%%%%%%%%%", (ftnlen)16); + e_wsfe(); + s_wsfe(&io___1650); +/* 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___1651); +/* 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___1652); +/* 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___1653); +/* 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___1654); +/* 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___1655); +/* 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___1656); +/* 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___1657); +/* 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___1658); +/* 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___1659); +/* 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(.) */ + + iiv = 1; + i__5 = *noinst; + for (iinst = 1; iinst <= i__5; ++iinst) { + if (comsize_1.isize[iiv - 1] == 1) { + if (iinst <= 9) { + s_wsfe(&io___1662); +/* 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___1663); +/* 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 (comsize_1.isize[iiv - 1] == 2) { + if (iinst <= 9) { + s_wsfe(&io___1664); +/* 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___1665); +/* 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 += comnvi_1.nsperi[iinst - 1]; +/* L5: */ + } + +/* do 5 iiv = 1 , nv */ +/* if (isize(iiv) .eq. 1) then */ +/* if(iiv.le.9) then */ +/* write(11,'(a8,i1,a)') */ +/* * sq//'setsize',iiv,sq//'smallvalue%' */ +/* else */ +/* write(11,'(a9,i2,a)') */ +/* * sq//'setsize{',iiv,'}'//sq//'smallvalue%' */ +/* end if */ +/* else if (isize(iiv) .eq. 2) then */ +/* if(iiv.le.9) then */ +/* write(11,'(a8,i1,a)') */ +/* * sq//'setsize',iiv,sq//'tinyvalue%' */ +/* else */ +/* write(11,'(a9,i2,a)') */ +/* * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' */ +/* end if */ +/* end if */ +/* 5 continue */ + + s_wsfi(&io___1667); + do_fio(&c__1, (char *)&(*fbar), (ftnlen)sizeof(real)); + e_wsfi(); + s_wsfe(&io___1668); +/* 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___1669); +/* 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___1670); +/* 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___1671); +/* 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___1672); +/* 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___1673); +/* 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___1674); +/* 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___1675); +/* 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___1676); +/* 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___1677); +/* 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___1678); +/* 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___1679); +/* 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___1680); +/* 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___1681); +/* 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___1684); +/* 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___1685); +/* 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___1689); +/* 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___1690); +/* 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___1692); +/* 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___1693); +/* 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___1694); +/* 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___1696); +/* 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___1697); +/* 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___1698); +/* 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___1699); +/* 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___1700); +/* 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___1701); +/* 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___1702); +/* 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___1703); +/* 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___1704); +/* 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___1705); +/* 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___1706); +/* 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___1710 = { 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___1710); +/* 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___1712 = { 0, 11, 0, "(a25,i1,a2,i1,a3)", 0 }; + static cilist io___1713 = { 0, 11, 0, "(a25,i1,a2,i2,a3)", 0 }; + static cilist io___1714 = { 0, 11, 0, "(a25,i2,a2,i1,a3)", 0 }; + static cilist io___1715 = { 0, 11, 0, "(a25,i2,a2,i2,a3)", 0 }; + static cilist io___1716 = { 0, 11, 0, "(a26,i1,a2,i1,a3)", 0 }; + static cilist io___1717 = { 0, 11, 0, "(a21,i1,a2)", 0 }; + static cilist io___1718 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1719 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1720 = { 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___1712); +/* 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___1713); +/* 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___1714); +/* 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___1715); +/* 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___1716); +/* 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___1717); +/* 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___1718); +/* 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___1719); +/* 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___1720); +/* 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), s_wsle(cilist *), + do_lio(integer *, integer *, char *, ftnlen), e_wsle(void), + lbit_shift(integer, integer), s_wsfi(icilist *), e_wsfi(void), + f_clos(cllist *); + + /* Local variables */ + static integer i__, kv, ib0, ib1, icm, ivt; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer isec, mend, ivtt; + extern /* Subroutine */ int stop1_(void); + static integer ndata, ibyte; + static char byteq[1*4]; + static integer iinst; + static char instq[10]; + static shortint iinsiv[24]; + static char tempoq[10]; + extern /* Subroutine */ int printl_(char *, ftnlen); + static integer nstaves; + + /* Fortran I/O blocks */ + static cilist io___1722 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1723 = { 0, 52, 0, "(a6,10Z4)", 0 }; + static cilist io___1728 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1729 = { 0, 52, 0, "(a6,8z4)", 0 }; + static cilist io___1730 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1731 = { 0, 52, 0, "(a)", 0 }; + static cilist io___1732 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1733 = { 0, 52, 0, "(a)", 0 }; + static cilist io___1736 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1737 = { 0, 52, 0, "(z4)", 0 }; + static cilist io___1738 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1739 = { 0, 52, 0, "(4z4)", 0 }; + static cilist io___1746 = { 0, 6, 0, 0, 0 }; + static cilist io___1750 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1751 = { 0, 52, 0, "(a4,z2,a7,11z4)", 0 }; + static cilist io___1752 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1753 = { 0, 52, 0, "(4z4)", 0 }; + static cilist io___1754 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1755 = { 0, 52, 0, "(a)", 0 }; + static icilist io___1757 = { 0, tempoq, 0, "(i2)", 10, 1 }; + static icilist io___1759 = { 0, instq, 0, "(i3)", 10, 1 }; + static cilist io___1760 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1761 = { 0, 52, 0, "(z4)", 0 }; + static cilist io___1762 = { 0, 51, 0, "(a,$)", 0 }; + static cilist io___1763 = { 0, 52, 0, "(4z4)", 0 }; + static cilist io___1764 = { 0, 6, 0, "(1x,a12,(10i6))", 0 }; + static cilist io___1765 = { 0, 15, 0, "(1x,a12,(10i6))", 0 }; + + + +/* Used to be icmm(0:nm); did midi fail when nv>16? */ + +/* data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ */ +/* Can't remember why these were not consecutive. */ +/* data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ */ + +/* Write Header */ + + s_wsfe(&io___1722); +/* 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___1723); + 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___1728); +/* 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___1729); + 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___1730); + do_fio(&c__1, jobname, (*ljob)); + e_wsfe(); + if (commidi_1.debugmidi) { + s_wsfe(&io___1731); +/* 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___1732); +/* 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___1733); +/* 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___1736); + *(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___1737); + 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___1738); + do_fio(&c__1, "\000\377/\000", (ftnlen)4); + e_wsfe(); + if (commidi_1.debugmidi) { + s_wsfe(&io___1739); + 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; + } + +/* 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 += comnvi_1.nsperi[iinst - 1]; + i__2 = comnvi_1.nsperi[iinst - 1]; + for (ivtt = 1; ivtt <= i__2; ++ivtt) { + ++ivt; + iinsiv[ivt - 1] = (shortint) iinst; +/* L13: */ + } + if (nstaves == all_1.nv) { + goto L14; + } +/* L12: */ + } + s_wsle(&io___1746); + do_lio(&c__9, &c__1, "Screwup!", (ftnlen)8); + e_wsle(); + stop1_(); +L14: + + 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[iinsiv[all_1.iv - 1] - 1] > 0) { + ndata = ndata + 4 + comtop_1.lnam[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___1750); +/* 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[all_1.iv - 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(); + if (commidi_1.debugmidi) { + s_wsfe(&io___1751); + 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[all_1.iv - 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(); + } + if (comtop_1.lnam[iinsiv[all_1.iv - 1] - 1] > 0) { + +/* Add instrument name as sequence name */ + + s_wsfe(&io___1752); +/* Writing concatenation */ + i__5[0] = 3, a__4[0] = "\000\377\003"; + *(unsigned char *)&ch__2[0] = comtop_1.lnam[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___1753); + 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[iinsiv[all_1.iv - 1] - 1] + , (ftnlen)sizeof(integer)); + e_wsfe(); + } + s_wsfe(&io___1754); + do_fio(&c__1, comtop_1.inameq + (iinsiv[all_1.iv - 1] - 1) * 79, + comtop_1.lnam[iinsiv[all_1.iv - 1] - 1]); + e_wsfe(); + if (commidi_1.debugmidi) { + s_wsfe(&io___1755); +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = "\""; + i__4[1] = comtop_1.lnam[iinsiv[all_1.iv - 1] - 1], a__3[1] = + comtop_1.inameq + (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[iinsiv[all_1.iv - 1] - 1] + + 2); + e_wsfe(); + } + } + s_wsfi(&io___1757); + do_fio(&c__1, (char *)&icm, (ftnlen)sizeof(integer)); + e_wsfi(); + s_wsfi(&io___1759); + do_fio(&c__1, (char *)&commidi_1.midinst[all_1.iv - 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___1760); + *(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___1761); + 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___1762); +/* 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___1763); + 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___1764); + 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___1765); + 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___1769 = { 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___1769); +/* 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___1772 = { 0, 6, 0, 0, 0 }; + static cilist io___1773 = { 0, 6, 0, 0, 0 }; + static icilist io___1777 = { 0, temq, 0, "(a9,i2,a1)", 20, 1 }; + static cilist io___1778 = { 0, 11, 0, "(a)", 0 }; + static cilist io___1780 = { 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___1772); + e_wsle(); + s_wsle(&io___1773); + 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___1777); +/* 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___1778); +/* 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___1780); +/* 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; } diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.c b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.c new file mode 100644 index 00000000000..9dd04f65961 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.c @@ -0,0 +1,2775 @@ +/* -- 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 all_1_ { + integer noinow, iorig[24], noinst; + logical insetup, replacing; + integer instnum[24]; + logical botv[24]; + integer nvi[24], nsyst, nvnow; +}; + +#define all_1 (*(struct all_1_ *) &all_) + +/* Initialized data */ + +struct { + integer e_1; + integer fill_2[24]; + integer e_3; + integer fill_4[26]; + logical e_5[24]; + integer e_6[24]; + integer fill_7[2]; + } all_ = { 24, {0}, 24, {0}, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, + FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, + FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, + FALSE_, FALSE_, FALSE_, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 }; + + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__1 = 1; +static integer c__27 = 27; +static integer c__2 = 2; +static integer c__128 = 128; +static integer c_n1 = -1; +static integer c__0 = 0; +static integer c__3 = 3; +static integer c__4 = 4; +static integer c__5 = 5; +static integer c__79 = 79; +static integer c__125 = 125; + +/* ccccccccccccccccccccccccc */ +/* c */ +/* c scor2prt 7/24/11 for PMX 2.615 */ +/* ccccccccccccccccccccccccc */ +/* This program, developed by Don Simons (dsimons@roadrunner.com), is */ +/* part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert */ +/* with MusiXTeX and TeX, the purpose of PMX is to allow the user to create */ +/* high-quality typeset musical scores by including a sequence of PMX commands */ +/* in an ASCII input file. Scor2prt is an auxiliary program that creates PMX */ +/* input files for individual parts from the PMX input file for the score. */ + +/* 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 . */ + + +/* 7/18/11 */ +/* Start to fix up for AS..., also Ki was done a little earlier. */ +/* 7/5/10 */ +/* Modify Manual to explain extended hex numbering for part-specific comments */ +/* 5/16/10 */ +/* Extend part-specific comments for up to 24 parts (subroutine chkcom) */ +/* Allow files 11-34 for parts */ +/* Change file 30 to 40 */ +/* 6/1/08 es2p */ +/* noimax = 24 */ + +/* To do */ +/* Override fracindent, musicsize? */ +/* Deal with midbar R? */ +/* 2/29/04 */ +/* Check for special character being in quoted string. */ +/* 10/20/02 PMX 2.407 */ +/* Interpret AN[n]"[used-defined-part-file-name]" */ +/* 1/21/02 */ +/* Deals with rm in multiple parts. */ +/* s2p15 */ +/* Get right non-tex index even if there's "\" inside D"..." */ +/* s2p14 */ +/* 10/29/00 fix transfer to parts of negative mtrdnp */ +/* 4/29/00 screen for "%%" followed by "T" */ +/* Restore change from "Version 2.1a, 21 Dec" */ +/* s2p13 */ +/* Allow whole-bar double-whole rests. */ +/* Bypass MIDI commands "I..." achar(10)="I" */ +/* s2p12 */ +/* Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla */ +/* only taken as such if ? represents a hex digit .le. noinst, otherwise it's */ +/* a simple comment. This lessens incompatibility. */ +/* In subroutine mbrest, properly open parts 10-12 if needed */ +/* s2p11 */ +/* Ignore leading blanks */ +/* Fix undefined linelength in mbrest at very end of comments. */ +/* s2p10 */ +/* Fix non-transfer of P..c" " */ +/* Allow "%%" and "%"n anywhere */ +/* Version 1.43 */ +/* Fix bug with P in TeX string. */ +/* Ignore shifted whole-bar rests when consolidating whole-bar rests */ +/* Copy type 4 TeX into all parts. */ +/* Deal with XB and XP. */ +/* Permit transfer of blank line into parts */ +/* Change staves/inst in 'M' command. */ +/* Arbitrary staves/inst. */ +/* Recognize m1/2/3/4 syntax. */ +/* Enable comment and one-voice syntax in instrument names */ + +/* Changes since 1.1 */ +/* Deal with saved macros. */ +/* Revise setup readin, to admit comments. */ +/* Do not copy 'X' into parts */ + +/* ccccccccccccccccccccccccccccccccccccccccccccccc */ +/* Main program */ int MAIN__(void) +{ + /* Initialized data */ + + static char achar[1*10] = "P" "m" "V" "R" "A" "h" "w" "K" "M" "I"; + + /* System generated locals */ + address a__1[2], a__2[3]; + integer i__1, i__2, i__3[2], i__4[3]; + char ch__1[44], ch__2[31], ch__3[4], ch__4[1], ch__5[2], ch__6[131]; + cilist ci__1; + icilist ici__1; + olist o__1; + cllist cl__1; + alist al__1; + inlist ioin__1; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), + e_rsfe(void); + /* Subroutine */ int s_stop(char *, ftnlen); + integer i_indx(char *, char *, ftnlen, ftnlen); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, + char **, integer *, integer *, ftnlen); + integer f_inqu(inlist *), f_open(olist *), s_cmp(char *, char *, ftnlen, + ftnlen), f_back(alist *), s_wsfe(cilist *), e_wsfe(void), s_rsfi( + icilist *), e_rsfi(void), f_clos(cllist *); + + /* Local variables */ + extern /* Subroutine */ int oddquotesbefore_(char *, integer *, logical *, + ftnlen); + static logical clefpend; + static real xmtrnum0; + static char templine[128]; + extern /* Subroutine */ int allparts_(char *, integer *, ftnlen); + static integer musicsize, ia, ib, ic, iv; + static char sq[1]; + static integer nv, idxendname; + static real fracindent; + static integer ibb, len, ivq, iend, nchk, idxa, ljob; + static char line[128]; + static integer isig, locp, idxq, ndxm, idxs, inst, idxq2, idxstartname; + extern integer iargc_(void); + static integer kvend; + extern /* Subroutine */ int zapbl_(char *, integer *, ftnlen); + static integer itemp, iinst, ntinx; + static logical oneof2; + extern doublereal readin_(char *, integer *, integer *, ftnlen); + extern /* Subroutine */ int chkcom_(char *, ftnlen), getarg_(integer *, + char *, ftnlen); + static integer npages; + static char holdln[128]; + static integer iudpfn; + static logical yesodd; + static integer ludpfn[24]; + static char udpfnq[128*24]; + static integer iiinst; + static logical fexist; + static integer ivlast, mtrdnp; + extern integer lenstr_(char *, integer *, ftnlen); + static logical frstln; + static integer insnow, ndxpmx, mtrnmp; + static logical isachar; + static char jobname[27]; + static integer lenhold, lenline; + static char infileq[27]; + static logical gotname; + static integer iccount, mtrdenl; + extern integer ntindex_(char *, char *, ftnlen, ftnlen); + static integer numargs; + extern /* Subroutine */ int mbrests_(integer *, char *, integer *, + integer *, char *, ftnlen, ftnlen); + static logical termrpt; + static integer mtrnuml; + static char termsym[2], instrum[128*24]; + static integer kvstart; + + /* Fortran I/O blocks */ + static cilist io___6 = { 0, 6, 0, 0, 0 }; + static cilist io___8 = { 0, 6, 0, 0, 0 }; + static cilist io___9 = { 0, 6, 0, 0, 0 }; + static cilist io___10 = { 0, 5, 0, "(a)", 0 }; + static cilist io___13 = { 0, 6, 0, 0, 0 }; + static cilist io___17 = { 0, 6, 0, 0, 0 }; + static cilist io___20 = { 0, 10, 0, "(a)", 0 }; + static cilist io___22 = { 0, 10, 0, "(a)", 0 }; + static cilist io___23 = { 0, 10, 0, "(a)", 0 }; + static cilist io___38 = { 0, 6, 0, 0, 0 }; + static cilist io___39 = { 0, 6, 0, 0, 0 }; + static cilist io___40 = { 0, 6, 0, 0, 0 }; + static cilist io___41 = { 0, 10, 0, "(a)", 0 }; + static cilist io___42 = { 0, 10, 0, "(a)", 0 }; + static cilist io___44 = { 0, 10, 0, "(a)", 0 }; + static cilist io___46 = { 0, 10, 0, "(a)", 0 }; + static cilist io___48 = { 0, 6, 0, 0, 0 }; + static cilist io___49 = { 0, 0, 0, "(a)", 0 }; + static cilist io___50 = { 0, 10, 0, "(a)", 0 }; + static cilist io___51 = { 0, 10, 0, "(a)", 0 }; + static cilist io___55 = { 0, 10, 0, "(a)", 0 }; + static cilist io___57 = { 0, 0, 0, "(a2/a)", 0 }; + static cilist io___59 = { 0, 10, 1, "(a)", 0 }; + static cilist io___61 = { 0, 10, 0, "(a)", 0 }; + static cilist io___62 = { 0, 10, 0, "(a)", 0 }; + static cilist io___68 = { 0, 6, 0, 0, 0 }; + static cilist io___69 = { 0, 6, 0, 0, 0 }; + static cilist io___72 = { 0, 10, 0, "(a)", 0 }; + static cilist io___76 = { 0, 6, 0, 0, 0 }; + static cilist io___77 = { 0, 6, 0, 0, 0 }; + static cilist io___78 = { 0, 6, 0, 0, 0 }; + static cilist io___81 = { 0, 10, 0, "(a)", 0 }; + static cilist io___83 = { 0, 6, 0, 0, 0 }; + static cilist io___84 = { 0, 6, 0, 0, 0 }; + static icilist io___85 = { 0, line+2, 0, "(i1)", 1, 1 }; + static icilist io___88 = { 0, line+2, 0, "(i2)", 2, 1 }; + static cilist io___89 = { 0, 6, 0, 0, 0 }; + static cilist io___90 = { 0, 6, 0, 0, 0 }; + static cilist io___97 = { 0, 0, 0, "(a)", 0 }; + static cilist io___102 = { 0, 0, 0, "(a)", 0 }; + static cilist io___103 = { 0, 0, 0, "(a)", 0 }; + + + clefpend = FALSE_; + all_1.insetup = TRUE_; + all_1.replacing = FALSE_; + frstln = TRUE_; + lenhold = 0; + *(unsigned char *)sq = '\\'; + s_wsle(&io___6); + do_lio(&c__9, &c__1, "This is scor2prt for PMX 2.615, 24 July 2011", ( + ftnlen)44); + e_wsle(); + numargs = iargc_(); + if (numargs == 0) { + s_wsle(&io___8); + do_lio(&c__9, &c__1, "You could have entered a jobname on the comman" + "d line,", (ftnlen)53); + e_wsle(); + s_wsle(&io___9); + do_lio(&c__9, &c__1, " but you may enter one now:", (ftnlen)32); + e_wsle(); + s_rsfe(&io___10); + do_fio(&c__1, jobname, (ftnlen)27); + e_rsfe(); + numargs = 1; + } else { +/* call getarg(1,jobname,idum) ! May need to replace this w/ next line */ + getarg_(&c__1, jobname, (ftnlen)27); + } + ljob = lenstr_(jobname, &c__27, (ftnlen)27); + if (ljob == 0) { + s_wsle(&io___13); + do_lio(&c__9, &c__1, "No was jobname entered. Restart and try again.", + (ftnlen)46); + e_wsle(); + s_stop("", (ftnlen)0); + } + +/* Strip ".pmx" if necessary */ + +/* Computing MAX */ + i__1 = i_indx(jobname, ".pmx", (ftnlen)27, (ftnlen)4), i__2 = i_indx( + jobname, ".PMX", (ftnlen)27, (ftnlen)4); + ndxpmx = max(i__1,i__2); + if (ndxpmx > 0) { + s_copy(jobname, jobname, (ftnlen)27, ndxpmx - 1); + ljob += -4; + } + +/* Check for existence of input file */ + +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".pmx"; + s_cat(infileq, a__1, i__3, &c__2, (ftnlen)27); + ioin__1.inerr = 0; + ioin__1.infilen = 27; + ioin__1.infile = infileq; + ioin__1.inex = &fexist; + ioin__1.inopen = 0; + ioin__1.innum = 0; + ioin__1.innamed = 0; + ioin__1.inname = 0; + ioin__1.inacc = 0; + ioin__1.inseq = 0; + ioin__1.indir = 0; + ioin__1.infmt = 0; + ioin__1.inform = 0; + ioin__1.inunf = 0; + ioin__1.inrecl = 0; + ioin__1.innrec = 0; + ioin__1.inblank = 0; + f_inqu(&ioin__1); + if (! fexist) { + s_wsle(&io___17); +/* Writing concatenation */ + i__3[0] = 17, a__1[0] = "Cannot find file "; + i__3[1] = 27, a__1[1] = infileq; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)44); + do_lio(&c__9, &c__1, ch__1, (ftnlen)44); + e_wsle(); + s_stop("", (ftnlen)0); + } + o__1.oerr = 0; + o__1.ounit = 10; + o__1.ofnmlen = ljob + 4; +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".pmx"; + s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)31); + o__1.ofnm = ch__2; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + +/* Open all instrument files now for allparts stuff. Later disgard those >nv */ + + for (iv = 1; iv <= 24; ++iv) { + all_1.iorig[iv - 1] = iv; + o__1.oerr = 0; + o__1.ounit = iv + 10; + o__1.ofnm = 0; + o__1.orl = 0; + o__1.osta = "SCRATCH"; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + ludpfn[iv - 1] = 0; +/* L19: */ + } + s_rsfe(&io___20); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + chkcom_(line, (ftnlen)128); + if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) == 0) { + allparts_(line, &c__128, (ftnlen)128); +L31: + s_rsfe(&io___22); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) != 0) { + allparts_(line, &c__128, (ftnlen)128); + goto L31; + } + allparts_(line, &c__128, (ftnlen)128); + s_rsfe(&io___23); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + chkcom_(line, (ftnlen)128); + } + iccount = 0; + nv = readin_(line, &iccount, &c__1, (ftnlen)128) + .1f; + all_1.noinst = readin_(line, &iccount, &c__2, (ftnlen)128) + .1f; + if (all_1.noinst > 0) { + all_1.nvi[0] = nv - all_1.noinst + 1; + } else { + all_1.noinst = 1 - all_1.noinst; + i__1 = all_1.noinst; + for (iinst = 1; iinst <= i__1; ++iinst) { + all_1.nvi[iinst - 1] = readin_(line, &iccount, &c_n1, (ftnlen)128) + + .1f; +/* L21: */ + } + } + all_1.noinow = all_1.noinst; + insnow = 1; + +/* ivlast is last iv in current inst. instnum(iv) is iinst for current voice. */ + + ivlast = all_1.nvi[0]; + i__1 = nv; + for (iv = 1; iv <= i__1; ++iv) { + all_1.instnum[iv - 1] = insnow; + if (iv == ivlast) { + if (iv < nv) { + all_1.botv[iv] = TRUE_; + } + +/* The previous stmt will set botv true only for bot voice of iinst>1. It is */ +/* used when writing termrpts, but the one in voice one is handled differently, */ +/* so botv(1) is left .false. */ + + if (insnow < all_1.noinst) { + ++insnow; + ivlast += all_1.nvi[insnow - 1]; + } + } +/* L22: */ + } + mtrnuml = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + mtrdenl = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + mtrnmp = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + mtrdnp = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + xmtrnum0 = readin_(line, &iccount, &c__0, (ftnlen)128); + isig = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + npages = readin_(line, &iccount, &c__3, (ftnlen)128) + .1f; + all_1.nsyst = readin_(line, &iccount, &c__0, (ftnlen)128) + .1f; + musicsize = readin_(line, &iccount, &c__4, (ftnlen)128) + .1f; + fracindent = readin_(line, &iccount, &c__5, (ftnlen)128); + if (npages == 0) { + s_wsle(&io___38); + do_lio(&c__9, &c__1, "You entered npages=0, which means nsyst is not" + " the total number", (ftnlen)63); + e_wsle(); + s_wsle(&io___39); + do_lio(&c__9, &c__1, "of systems. Scor2prt has to know the total nu" + "mber of systems.", (ftnlen)62); + e_wsle(); + s_wsle(&io___40); + do_lio(&c__9, &c__1, "Please set npages and nsyst to their real valu" + "es.", (ftnlen)49); + e_wsle(); + s_stop("", (ftnlen)0); + } + +/* Must leave insetup=.true. else could bypass ALL instrument names. */ + + s_rsfe(&io___41); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + chkcom_(line, (ftnlen)128); + al__1.aerr = 0; + al__1.aunit = 10; + f_back(&al__1); + +/* Normally this puts pointer at start of line with 1st inst name */ +/* Check if prior line was "%%" */ + + al__1.aerr = 0; + al__1.aunit = 10; + f_back(&al__1); + s_rsfe(&io___42); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (s_cmp(line, "%%", (ftnlen)2, (ftnlen)2) == 0) { + al__1.aerr = 0; + al__1.aunit = 10; + f_back(&al__1); + } + i__1 = all_1.noinst; + for (iv = 1; iv <= i__1; ++iv) { + gotname = FALSE_; +L16: + s_rsfe(&io___44); + do_fio(&c__1, instrum + (iv - 1 << 7), (ftnlen)128); + e_rsfe(); + if (s_cmp(instrum + (iv - 1 << 7), "%%", (ftnlen)2, (ftnlen)2) == 0) { + s_rsfe(&io___46); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + goto L16; + } else if (*(unsigned char *)&instrum[(iv - 1) * 128] == '%') { + ivq = *(unsigned char *)&instrum[(iv - 1 << 7) + 1] - 48; + if (ivq != iv) { + +/* It's really a comment. Copy to parts, then get another trial name. */ + + allparts_(instrum + (iv - 1 << 7), &c__128, (ftnlen)128); + goto L16; + } else { + s_copy(line, instrum + ((iv - 1 << 7) + 2), (ftnlen)128, ( + ftnlen)126); + s_copy(instrum + (iv - 1 << 7), line, (ftnlen)128, (ftnlen) + 128); + gotname = TRUE_; + } + } else { + gotname = TRUE_; + } +/* c */ +/* c The following checks for macro that write original C-clef as part of */ +/* c instrument name. See pmx.tex */ +/* c */ +/* if (index(instrum(iv),'namewpc') .eq. 0) then */ +/* write(10+iv,'(a)')' ' */ +/* else */ +/* inm1 = index(instrum(iv),'{')+1 */ +/* inm2 = index(instrum(iv),'}')-1 */ +/* read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 */ +/* write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// */ +/* * char(iy1+49)//char(iy2+49) */ +/* instrum(iv) = instrum(iv)(inm1:inm2) */ +/* end if */ + if (! gotname) { + s_wsle(&io___48); + do_lio(&c__9, &c__1, "You must provide a replacement instrument " + "name", (ftnlen)46); + e_wsle(); + s_stop("", (ftnlen)0); + } + io___49.ciunit = iv + 10; + s_wsfe(&io___49); + do_fio(&c__1, " ", (ftnlen)1); + e_wsfe(); +/* L14: */ + } + all_1.replacing = FALSE_; + all_1.nvnow = nv; + +/* Clef string: Note insetup is still T, so "%%" will be treated specially */ + + s_rsfe(&io___50); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + chkcom_(line, (ftnlen)128); + if (all_1.replacing) { + +/* If here, we have next line after "%%", containing score's clef string */ +/* Assume all clefs are handled with instrument comments. */ + + s_rsfe(&io___51); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + chkcom_(line, (ftnlen)128); + al__1.aerr = 0; + al__1.aunit = 10; + f_back(&al__1); + } else { + +/* If here, line has the clef string in it. Handle the old way */ + + kvstart = 1; + kvend = all_1.nvi[0]; + i__1 = all_1.noinst; + for (inst = 1; inst <= i__1; ++inst) { + ci__1.cierr = 0; + ci__1.ciunit = inst + 10; +/* Writing concatenation */ + i__4[0] = 2, a__2[0] = "(a"; + *(unsigned char *)&ch__4[0] = all_1.nvi[inst - 1] + 48; + i__4[1] = 1, a__2[1] = ch__4; + i__4[2] = 1, a__2[2] = ")"; + ci__1.cifmt = (s_cat(ch__3, a__2, i__4, &c__3, (ftnlen)4), ch__3); + s_wsfe(&ci__1); + do_fio(&c__1, line + (kvstart - 1), kvend - (kvstart - 1)); + e_wsfe(); + if (inst < all_1.noinst) { + kvstart = kvend + 1; + kvend = kvstart + all_1.nvi[inst] - 1; + } +/* L2: */ + } + } + all_1.replacing = FALSE_; + all_1.insetup = FALSE_; + +/* *****NOTE*****This comment applies to stuff done earlier! */ +/* Before starting the big loop, copy initial instnum and staffnum stuff */ +/* into working values. Latter may change if noinst changes. Also make */ +/* list of current inst nums relative to original ones. In addition to those */ +/* below, must redo instnum(iv) and botv(iv) when we change noinst. */ + +/* Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! */ + +L18: + s_rsfe(&io___55); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (*(unsigned char *)line == '%') { + allparts_(line, &c__128, (ftnlen)128); + goto L18; + } + allparts_(line, &c__128, (ftnlen)128); + +/* Write instrument names. Will be blank if later part of a score. */ + + if (*(unsigned char *)&instrum[0] != ' ') { + i__1 = all_1.noinst; + for (iv = 1; iv <= i__1; ++iv) { + len = lenstr_(instrum + (iv - 1 << 7), &c__79, (ftnlen)128); + io___57.ciunit = iv + 10; + s_wsfe(&io___57); + do_fio(&c__1, "Ti", (ftnlen)2); + do_fio(&c__1, instrum + (iv - 1 << 7), len); + e_wsfe(); +/* L3: */ + } + } + +/* The big loop. Except for '%%', put all comment lines in all parts. */ +/* Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts */ +/* If a line starts with %!, put the rest of it in each part. */ +/* If a line starts with %[n], put the rest of it in part [n]. */ +/* Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. */ +/* Assume they only come at top of block, except terminal repeat needs */ +/* special handling. */ +/* Check for "P"; ignore in parts. */ +/* Check for consecutive full-bar rests; if found, replace with rm[nn] */ + + iv = 1; + iinst = 1; + termrpt = FALSE_; +L4: + i__1 = s_rsfe(&io___59); + if (i__1 != 0) { + goto L999; + } + i__1 = do_fio(&c__1, line, (ftnlen)128); + if (i__1 != 0) { + goto L999; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L999; + } + lenline = lenstr_(line, &c__128, (ftnlen)128); + if (lenline == 0) { + goto L4; + } + zapbl_(line, &c__128, (ftnlen)128); + chkcom_(line, (ftnlen)128); + lenline = lenstr_(line, &c__128, (ftnlen)128); + if (lenline == 0) { + goto L4; + } + if (*(unsigned char *)line == 'T') { + allparts_(line, &c__128, (ftnlen)128); + s_rsfe(&io___61); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + allparts_(line, &c__128, (ftnlen)128); + goto L4; + } else /* if(complicated condition) */ { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = sq; + i__3[1] = 1, a__1[1] = sq; + s_cat(ch__5, a__1, i__3, &c__2, (ftnlen)2); + if (s_cmp(line, ch__5, (ftnlen)2, (ftnlen)2) == 0) { + allparts_(line, &c__128, (ftnlen)128); + goto L4; + } else if (i_indx("hl", line, (ftnlen)2, (ftnlen)1) > 0 && i_indx( + " +-", line + 1, (ftnlen)3, (ftnlen)1) > 0) { + allparts_(line, &c__128, (ftnlen)128); + s_rsfe(&io___62); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + allparts_(line, &c__128, (ftnlen)128); + goto L4; + } else if (iv == 1) { + for (ia = 1; ia <= 10; ++ia) { +L24: + idxa = ntindex_(line, achar + (ia - 1), (ftnlen)128, (ftnlen) + 1); + isachar = idxa > 0; + if (idxa > 1) { + i__1 = idxa - 2; + isachar = s_cmp(line + i__1, " ", idxa - 1 - i__1, ( + ftnlen)1) == 0; + } + +/* 1 2 3 4 5 6 7 8 9 10 */ +/* data achar /'P','m','V','R','A','h','w','K','M','I'/ */ + + if (ia == 9) { + i__1 = idxa; + isachar = isachar && s_cmp(line + i__1, "S", idxa + 1 - + i__1, (ftnlen)1) == 0; + } + if (isachar) { + +/* Check whether character is inside a quoted string by counting */ +/* how many quotes precede it in the line */ + + oddquotesbefore_(line, &idxa, &yesodd, (ftnlen)128); + if (yesodd) { + isachar = FALSE_; + } + } + if (isachar) { + +/* Find next blank */ + + for (ib = idxa + 1; ib <= 128; ++ib) { + if (*(unsigned char *)&line[ib - 1] == ' ') { + goto L7; + } +/* L6: */ + } + s_wsle(&io___68); + do_lio(&c__9, &c__1, "Problem with \"V,R,m,P,A,h,MS, o" + "r w\"", (ftnlen)35); + e_wsle(); + s_wsle(&io___69); + do_lio(&c__9, &c__1, "Send files to Dr. Don at dsimons a" + "t roadrunner dot com", (ftnlen)54); + e_wsle(); + s_stop("1", (ftnlen)1); +L7: + +/* Next blank is at position ib. Later, if ia=1, must check for Pc" " ; */ +/* i.e., look for '"' between P and blank */ + + if (ia == 4) { + +/* Check for terminal repeat. Note if there's a term rpt, there can't be any */ +/* others. Also, must process repeats LAST, after m's and 'V's */ + + for (ic = ib + 1; ic <= 128; ++ic) { + +/* If any subsequent character on this line is neither blank nor "/", get out */ + + if (i_indx(" /", line + (ic - 1), (ftnlen)2, ( + ftnlen)1) == 0) { + goto L9; + } + if (*(unsigned char *)&line[ic - 1] == '/') { + termrpt = TRUE_; + i__1 = ib - 3; + s_copy(termsym, line + i__1, (ftnlen)2, ib - + 1 - i__1); + +/* Process the line as if there were no "R" */ + + goto L10; + } +/* L8: */ + } + +/* +++ 060812 */ +/* If here, all chars after "R" symbol are blanks, so process the line normally, */ +/* but only IF next line is not the M-Tx line " /" */ + + s_rsfe(&io___72); + do_fio(&c__1, templine, (ftnlen)128); + e_rsfe(); + if (s_cmp(templine, " /", (ftnlen)2, (ftnlen)2) != 0) + { + al__1.aerr = 0; + al__1.aunit = 10; + f_back(&al__1); +/* and flow out */ + } else { + +/* We have the M-Tx case where one line ends with R? and next is " /". Add / to the line, */ +/* and proceed as above */ + +/* Writing concatenation */ + i__3[0] = ib, a__1[0] = line; + i__3[1] = 1, a__1[1] = "/"; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + lenline += 2; + termrpt = TRUE_; + i__1 = ib - 3; + s_copy(termsym, line + i__1, (ftnlen)2, ib - 1 - + i__1); + goto L10; + } +/* +++ 060812 */ + + } else if (ia == 1) { + idxq = ntindex_(line, "\"", (ftnlen)128, (ftnlen)1); + if (idxq > idxa && idxq < ib) { + +/* Quote is between P and next blank. Find 2nd quote, starting at the blank. */ + + idxq2 = ib - 1 + ntindex_(line, "\"", (ftnlen)128, + (ftnlen)1); + i__1 = idxq2; + if (idxq == 0 || s_cmp(line + i__1, " ", idxq2 + + 1 - i__1, (ftnlen)1) != 0) { + s_wsle(&io___76); + e_wsle(); + s_wsle(&io___77); + do_lio(&c__9, &c__1, "Error copying P with q" + "uotes, idxq2:", (ftnlen)35); + do_lio(&c__3, &c__1, (char *)&idxq2, (ftnlen) + sizeof(integer)); + e_wsle(); + s_wsle(&io___78); + do_lio(&c__9, &c__1, line, (ftnlen)60); + e_wsle(); + s_stop("1", (ftnlen)1); + } + ib = idxq2 + 1; + } + +/* Do not transfer P into parts. */ + + goto L12; + } else if (ia == 9) { + +/* Start Saving a macro. After leaving here, a symbol will be sent to all parts, */ +/* If all on this line, set ib to end and exit normally. */ + + i__1 = ib; + ndxm = i_indx(line + i__1, "M", 128 - i__1, (ftnlen)1) + ; + i__1 = ib + ndxm - 2; + if (ndxm > 0 && s_cmp(line + i__1, " ", ib + ndxm - 1 + - i__1, (ftnlen)1) == 0) { + +/* Macro ends on this line */ + + ib = ib + ndxm + 1; + } else { + +/* Save leading part of current line */ + + lenhold = idxa - 1; + if (lenhold > 0) { + s_copy(holdln, line, (ftnlen)128, lenhold); + } + +/* Transfer rest of line */ + + i__1 = 129 - idxa; + allparts_(line + (idxa - 1), &i__1, 128 - (idxa - + 1)); + +/* Read next line */ + +L20: + s_rsfe(&io___81); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + +/* Check for comment, transfer and loop if so */ + +/* if (line(1:1) .eq.'%') then */ +L23: + if (*(unsigned char *)line == '%') { +/* call allparts(line,128) */ +/* go to 20 */ + chkcom_(line, (ftnlen)128); + goto L23; + } + +/* Look for terminal ' M' */ + + if (*(unsigned char *)line == 'M') { + ndxm = 1; + } else { + ndxm = i_indx(line, " M", (ftnlen)128, ( + ftnlen)2); + if (ndxm > 0) { + ++ndxm; + } + } + if (ndxm > 0) { + +/* Set parameters, exit normally (but later check for leading part of 1st line */ + + idxa = 1; + ib = ndxm + 1; + } else { + +/* No "M", transfer entire line, loop */ + + allparts_(line, &c__128, (ftnlen)128); + goto L20; + } + } + } else if (ia == 10) { + +/* Do not transfer MIDI command into parts */ + + goto L12; + } else if (ia == 5) { + +/* First check for "AS", but S may come after other "A" options */ + + i__1 = idxa; + idxs = i_indx(line + i__1, "S", ib - i__1, (ftnlen)1); + if (idxs > 0) { + +/* Get rid of the string. First check if that's all there is in A. */ + + if (ib - idxa == nv + 2) { + goto L12; + } + i__1 = idxa + idxs + nv; +/* Writing concatenation */ + i__3[0] = idxa + idxs - 1, a__1[0] = line; + i__3[1] = ib - i__1, a__1[1] = line + i__1; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + } + +/* Check for user-defined part file name. Must start in column 1 and have */ +/* AN[n]"userfilename". */ +/* idxa is position of "A" */ +/* ib is position of the next blank after "A" */ +/* Don't allow any blanks in user */ + + i__1 = idxa; + if (s_cmp(line + i__1, "N", idxa + 1 - i__1, (ftnlen) + 1) != 0) { + goto L9; + } +/* bail out */ + if (idxa != 1) { + s_wsle(&io___83); + e_wsle(); + s_wsle(&io___84); + do_lio(&c__9, &c__1, "You entered \"AN...\" some" + "where beyond first column; stopping.", ( + ftnlen)60); + e_wsle(); + s_stop("1", (ftnlen)1); + } + +/* pmxa already checked for valid one- or 2-digit number, so get it */ + + if (*(unsigned char *)&line[3] == '"') { + +/* Single digit instrument number */ + + s_rsfi(&io___85); + do_fio(&c__1, (char *)&iudpfn, (ftnlen)sizeof( + integer)); + e_rsfi(); + idxstartname = 5; + } else { + s_rsfi(&io___88); + do_fio(&c__1, (char *)&iudpfn, (ftnlen)sizeof( + integer)); + e_rsfi(); + idxstartname = 6; + } + ludpfn[iudpfn - 1] = i_indx(line + (idxstartname - 1), + "\"", 128 - (idxstartname - 1), (ftnlen)1) - + 1; + if (ludpfn[iudpfn - 1] < 0) { + s_wsle(&io___89); + e_wsle(); + s_wsle(&io___90); + do_lio(&c__9, &c__1, "User-defined part file nam" + "e must be in quotes", (ftnlen)45); + e_wsle(); + s_stop("1", (ftnlen)1); + } + idxendname = idxstartname + ludpfn[iudpfn - 1] - 1; + s_copy(udpfnq + (iudpfn - 1 << 7), line + ( + idxstartname - 1), (ftnlen)128, idxendname - ( + idxstartname - 1)); + +/* Get a new line! */ + + goto L4; + } else if (ia == 8) { + +/* Key change/transposition. */ +/* If not instrument specific, copy to all parts */ + + i__1 = idxa; + if (s_cmp(line + i__1, "i", idxa + 1 - i__1, (ftnlen) + 1) != 0) { + goto L9; + } + +/* Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]... */ + + ibb = idxa + 2; +/* Starts on digit after 'i' */ +L40: + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = 1; + ici__1.iciunit = line + (ibb - 1); + ici__1.icifmt = "(i1)"; + s_rsfi(&ici__1); + do_fio(&c__1, (char *)&iiinst, (ftnlen)sizeof(integer) + ); + e_rsfi(); +/* 1st digit of iinst */ + i__1 = ibb; + itemp = i_indx("01234567890", line + i__1, (ftnlen)11, + ibb + 1 - i__1); + if (itemp > 0) { + ++ibb; + iiinst = iiinst * 10 + itemp - 1; + } + ++ibb; +/* now at first +/-. Need end of 2nd number */ + i__1 = ibb; + itemp = i_indx(line + i__1, "i", ib - i__1, (ftnlen)1) + ; +/* Rel pos'n of next 'i' */ + if (itemp > 0) { + iend = ibb + itemp - 1; + } else { + iend = ib - 1; + } + io___97.ciunit = all_1.iorig[iiinst - 1] + 10; + s_wsfe(&io___97); +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = "Ki1"; + i__3[1] = iend - (ibb - 1), a__1[1] = line + (ibb - 1) + ; + s_cat(ch__6, a__1, i__3, &c__2, (ftnlen)131); + do_fio(&c__1, ch__6, iend - (ibb - 1) + 3); + e_wsfe(); + if (itemp > 0) { + ibb = iend + 2; + goto L40; + } + goto L12; +/* Remove K command from string, go to next ia */ + } +L9: + i__1 = ib - idxa; + allparts_(line + (idxa - 1), &i__1, ib - 1 - (idxa - 1)); +L12: + +/* Remove the string from line */ + + if (idxa == 1) { + s_copy(line, line + (ib - 1), (ftnlen)128, 128 - (ib + - 1)); + } else { +/* Writing concatenation */ + i__3[0] = idxa - 1, a__1[0] = line; + i__3[1] = 128 - (ib - 1), a__1[1] = line + (ib - 1); + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + } + lenline = lenstr_(line, &c__128, (ftnlen)128); + +/* Loop if only blanks are left */ + + if (lenline == 0) { + goto L4; + } + +/* Must check for multiple "I" commands, so go to just after start of ia loop */ + + if (ia == 10) { + goto L24; + } + +/* Tack on front part from 1st line of saved macro */ + + if (lenhold > 0) { +/* Writing concatenation */ + i__4[0] = lenhold, a__2[0] = holdln; + i__4[1] = 1, a__2[1] = " "; + i__4[2] = lenline, a__2[2] = line; + s_cat(line, a__2, i__4, &c__3, (ftnlen)128); + lenhold = 0; + } + } +/* L5: */ + } + } + } + +/* Now a special loop to deal with 'X'. If it was %[n]X..., will have been */ +/* copied into part [n] already. If no "B" or "P", remove. If "P", just */ +/* remove the "P" so pmxa/b will process. If "B". do nothing. */ + +L10: + nchk = 1; +L13: + ntinx = nchk - 1 + ntindex_(line + (nchk - 1), "X", 128 - (nchk - 1), ( + ftnlen)1); + if (ntinx > nchk - 1) { + +/* There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. */ + + if (ntinx > 1) { + i__1 = ntinx - 2; + if (s_cmp(line + i__1, " ", ntinx - 1 - i__1, (ftnlen)1) != 0) { + +/* The X is not 1st char of PMX command. Advance starting point, loop. */ + + nchk = ntinx + 1; + goto L13; + } + } + +/* We now know the X at ntinx starts a PMX command. Find next blank */ + + i__1 = ntinx; + ib = ntinx + i_indx(line + i__1, " ", 128 - i__1, (ftnlen)1); + +/* There must be a blank to right of "X", so ib>ntinx */ + +/* locp = nchk-1+index(line(nchk:ib),'P') */ + i__1 = ntinx; + locp = ntinx + i_indx(line + i__1, "P", ib - i__1, (ftnlen)1); + +/* Did not need to use ntindex because we already know bounds of PMX command. */ + +/* if (locp .gt. nchk-1) then */ + if (locp > ntinx) { + +/* Strip out the 'P' */ + + s_copy(templine, line, (ftnlen)128, locp - 1); + i__1 = locp; +/* Writing concatenation */ + i__3[0] = locp - 1, a__1[0] = templine; + i__3[1] = lenline - i__1, a__1[1] = line + i__1; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + --lenline; + --ib; + } + if (i_indx(line + (ntinx - 1), ":", ib - (ntinx - 1), (ftnlen)1) > 0 + || i_indx(line + (ntinx - 1), "S", ib - (ntinx - 1), (ftnlen) + 1) > 0 || i_indx(line + (ntinx - 1), "B", ib - (ntinx - 1), ( + ftnlen)1) > 0 || locp > ntinx) { + +/* The X command is a shift, "Both", or "Part". Do not remove. */ + + nchk = ib + 1; + goto L13; + } + +/* Remove the X command. */ + + if (ntinx == 1) { + if (ib < lenline) { + i__1 = ib; + s_copy(line, line + i__1, (ftnlen)128, lenline - i__1); + } else { + +/* line contains ONLY the "X" command, so get a new line */ + + goto L4; + } + } else { + s_copy(templine, line, (ftnlen)128, ntinx - 1); + if (ib < lenline) { + i__1 = ib; +/* Writing concatenation */ + i__3[0] = ntinx - 1, a__1[0] = templine; + i__3[1] = lenline - i__1, a__1[1] = line + i__1; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + } else { + s_copy(line, templine, (ftnlen)128, ntinx - 1); + } + } + +/* Recompute lenline */ + + lenline = lenstr_(line, &c__128, (ftnlen)128); + +/* Resume checking after location of removed command. */ + + nchk = ntinx; + goto L13; + } + +/* End of loop for X-checks */ + + oneof2 = ntindex_(line, "//", (ftnlen)128, (ftnlen)2) > 0; + if (termrpt && all_1.botv[iv - 1] && frstln && *(unsigned char *)&line[ + lenline - 1] == '/') { + +/* Must add a terminal repeat before the slash */ + + if (oneof2) { + --lenline; + } + if (lenline > 1) { + io___102.ciunit = all_1.iorig[iinst - 1] + 10; + s_wsfe(&io___102); + do_fio(&c__1, line, lenline - 1); + e_wsfe(); + } + if (! oneof2) { +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = termsym; + i__3[1] = 2, a__1[1] = " /"; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + lenline = 4; + } else { +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = termsym; + i__3[1] = 3, a__1[1] = " //"; + s_cat(line, a__1, i__3, &c__2, (ftnlen)128); + lenline = 5; + } + } + if (termrpt && frstln && *(unsigned char *)&line[lenline - 1] == '/' && + iv == all_1.nvnow) { + termrpt = FALSE_; + } + io___103.ciunit = all_1.iorig[iinst - 1] + 10; + s_wsfe(&io___103); + do_fio(&c__1, line, lenline); + e_wsfe(); + if (oneof2) { + frstln = FALSE_; + } else if (! frstln) { + frstln = TRUE_; + } +/* if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then */ + if (ntindex_(line, "/", (ftnlen)128, (ftnlen)1) > 0 && ntindex_(line, + "//", (ftnlen)128, (ftnlen)2) == 0) { + iv = iv % all_1.nvnow + 1; + iinst = all_1.instnum[iv - 1]; + } + goto L4; +L999: + cl__1.cerr = 0; + cl__1.cunit = 10; + cl__1.csta = 0; + f_clos(&cl__1); + +/* In the mbrest checks, must run through ALL noinst files (not just noinow) */ + + i__1 = all_1.noinst; + for (iinst = 1; iinst <= i__1; ++iinst) { +/* cc+++ */ +/* c */ +/* c Temporarily transfer entire scratch file to real file */ +/* c */ +/* rewind(10+iinst) */ +/* open(40,file='s2pout'//char(48+iinst)//'.pmx') */ +/* do 50 m = 1 , 10000 */ +/* read(10+iinst,'(a)',end=51)line */ +/* lenline = lenstr(line,128) */ +/* if (lenline .ge. 1) then */ +/* write(40,'(a)')line(1:lenline) */ +/* else */ +/* write(40,'(a)')' ' */ +/* end if */ +/* 50 continue */ +/* 51 continue */ +/* close(40) */ +/* cc+++ */ + if (all_1.nvi[iinst - 1] == 1) { + mbrests_(&iinst, jobname, &ljob, &ludpfn[iinst - 1], udpfnq + ( + iinst - 1 << 7), (ftnlen)27, (ftnlen)128); + } else { + +/* Send a signal with ljob to bypass most mbrest processing */ + + i__2 = -ljob; + mbrests_(&iinst, jobname, &i__2, &ludpfn[iinst - 1], udpfnq + ( + iinst - 1 << 7), (ftnlen)27, (ftnlen)128); + } +/* L11: */ + } + return 0; +} /* MAIN__ */ + +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_ */ + +/* Subroutine */ int allparts_(char *string, integer *n, ftnlen string_len) +{ + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + + /* Local variables */ + static integer len, iinst; + extern integer lenstr_(char *, integer *, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___106 = { 0, 0, 0, "(a)", 0 }; + + + len = lenstr_(string, n, string_len); + if (len == 0) { + len = 1; + s_copy(string, " ", string_len, (ftnlen)1); + } + i__1 = all_1.noinow; + for (iinst = 1; iinst <= i__1; ++iinst) { + io___106.ciunit = all_1.iorig[iinst - 1] + 10; + s_wsfe(&io___106); + do_fio(&c__1, string, len); + e_wsfe(); +/* L1: */ + } + return 0; +} /* allparts_ */ + +/* Subroutine */ int mbrests_(integer *iv, char *jobname, integer *ljob, + integer *ludpfn, char *udpfnq, ftnlen jobname_len, ftnlen udpfnq_len) +{ + /* System generated locals */ + address a__1[2], a__2[3]; + integer i__1[2], i__2[3], i__3, i__4; + real r__1; + char ch__1[1], ch__2[18], ch__3[4], ch__4[2], ch__5[10]; + cilist ci__1; + icilist ici__1; + olist o__1; + cllist cl__1; + alist al__1; + + /* Builtin functions */ + integer f_rew(alist *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer f_open(olist *), s_rsfe(cilist *), do_fio(integer *, char *, + ftnlen), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen), + s_wsfe(cilist *), e_wsfe(void), s_wsle(cilist *), do_lio(integer * + , integer *, char *, ftnlen), e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen); + integer i_indx(char *, char *, ftnlen, ftnlen), s_rsfi(icilist *), e_rsfi( + void); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + double r_lg10(real *); + integer f_clos(cllist *); + + /* Local variables */ + static integer i__, il, iw; + static char sq[1]; + static integer ip1, ipc, ipe, len, idx; + static char sym[80]; + static integer ndig; + static char line[128*50]; + static integer idxb, nmbr, idxs, lsym; + static char line1[128]; + static logical type4; + static integer icden, iline, lpart; + static char partq[2]; + static integer lwbrs, nwbrs, lenbar, ipenew, mtrden; + static logical wbrest; + extern integer lenstr_(char *, integer *, ftnlen); + static logical newmtr; + static integer lwbrsx, mtrnum; + static char wbrsym[3*2]; + static integer lenbeat; + static logical alldone; + extern integer ifnodur_(integer *, char *, ftnlen), ntindex_(char *, char + *, ftnlen, ftnlen); + static integer lenmult; + extern /* Subroutine */ int dosetup_(integer *, char *, integer *, + integer *, ftnlen); + static logical rpfirst; + extern /* Subroutine */ int fwbrsym_(integer *, integer *, char *, + integer *, ftnlen), nextsym_(char *, integer *, integer *, + integer *, char *, integer *, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___113 = { 0, 0, 0, "(a)", 0 }; + static cilist io___116 = { 0, 40, 0, "(a)", 0 }; + static cilist io___117 = { 0, 40, 0, "(a)", 0 }; + static cilist io___118 = { 0, 6, 0, 0, 0 }; + static cilist io___121 = { 0, 0, 1, "(a)", 0 }; + static cilist io___122 = { 0, 40, 0, "(a)", 0 }; + static cilist io___123 = { 0, 0, 0, "(a)", 0 }; + static cilist io___124 = { 0, 40, 0, "(a)", 0 }; + static cilist io___144 = { 0, 0, 1, "(a)", 0 }; + static cilist io___145 = { 0, 40, 0, "(a)", 0 }; + static cilist io___146 = { 0, 40, 0, "(a)", 0 }; + static cilist io___147 = { 0, 6, 0, 0, 0 }; + static cilist io___152 = { 0, 40, 0, "(a)", 0 }; + static cilist io___154 = { 0, 6, 0, 0, 0 }; + static cilist io___156 = { 0, 40, 0, "(a)", 0 }; + static cilist io___158 = { 0, 40, 0, "(a)", 0 }; + static cilist io___159 = { 0, 40, 0, "(a)", 0 }; + static cilist io___160 = { 0, 40, 0, "(a)", 0 }; + static cilist io___161 = { 0, 40, 0, "(a)", 0 }; + + + type4 = FALSE_; + *(unsigned char *)sq = '\\'; + alldone = FALSE_; + al__1.aerr = 0; + al__1.aunit = *iv + 10; + f_rew(&al__1); +/* open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') */ + if (*iv < 10) { + *(unsigned char *)partq = (char) (*iv + 48); + lpart = 1; + +/* 5/16/10 Fix for >20 parts */ + +/* else */ +/* partq = '1'//char(38+iv) */ +/* lpart = 2 */ + } else { + lpart = 2; + if (*iv < 20) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = "1"; + *(unsigned char *)&ch__1[0] = *iv + 38; + i__1[1] = 1, a__1[1] = ch__1; + s_cat(partq, a__1, i__1, &c__2, (ftnlen)2); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = "2"; + *(unsigned char *)&ch__1[0] = *iv + 28; + i__1[1] = 1, a__1[1] = ch__1; + s_cat(partq, a__1, i__1, &c__2, (ftnlen)2); + } + } +/* if (ludpfn .eq. 0) then */ + o__1.oerr = 0; + o__1.ounit = 40; + o__1.ofnmlen = abs(*ljob) + lpart + 4; +/* Writing concatenation */ + i__2[0] = abs(*ljob), a__2[0] = jobname; + i__2[1] = lpart, a__2[1] = partq; + i__2[2] = 4, a__2[2] = ".pmx"; + s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)18); + o__1.ofnm = ch__2; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); +/* else */ +/* open(30,file=udpfnq(1:ludpfn)//'.pmx') */ +/* end if */ + for (i__ = 1; i__ <= 10000; ++i__) { + io___113.ciunit = *iv + 10; + s_rsfe(&io___113); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (*(unsigned char *)&line[0] == '%' || s_cmp(line, "---", (ftnlen)3, + (ftnlen)3) == 0 || type4) { + len = lenstr_(line, &c__128, (ftnlen)128); + if (len > 0) { + s_wsfe(&io___116); + do_fio(&c__1, line, len); + e_wsfe(); + } else { + s_wsfe(&io___117); + do_fio(&c__1, " ", (ftnlen)1); + e_wsfe(); + } + if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) == 0) { + type4 = ! type4; + } + } else { + goto L11; + } +/* L10: */ + } + s_wsle(&io___118); + do_lio(&c__9, &c__1, "You should not be here in scor2prt. Call Dr. Don", + (ftnlen)49); + e_wsle(); + s_stop("", (ftnlen)0); +L11: + +/* Finished reading opening type4 TeX and comments. Next line to be read */ +/* will contain the first of the input numbers */ + + dosetup_(iv, line, &mtrnum, &mtrden, (ftnlen)128); + for (i__ = 1; i__ <= 10000; ++i__) { +L13: + io___121.ciunit = *iv + 10; + i__3 = s_rsfe(&io___121); + if (i__3 != 0) { + goto L999; + } + i__3 = do_fio(&c__1, line, (ftnlen)128); + if (i__3 != 0) { + goto L999; + } + i__3 = e_rsfe(); + if (i__3 != 0) { + goto L999; + } +L7: + len = lenstr_(line, &c__128, (ftnlen)128); + +/* Pass-through if instrumnet has >1 voice. */ + + if (*ljob < 0) { + goto L2; + } + if (i_indx("TtTiTch+h-h l ", line, (ftnlen)14, (ftnlen)2) > 0) { + +/* Traps titles, instruments, composers, headers, lower strings. Read 2 lines. */ + + s_wsfe(&io___122); + do_fio(&c__1, line, len); + e_wsfe(); + io___123.ciunit = *iv + 10; + s_rsfe(&io___123); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + len = lenstr_(line, &c__128, (ftnlen)128); + goto L2; + } + if (i__ == 1 || i__ > 5 && *(unsigned char *)&line[0] == 'm') { + +/* NOTE! The above test is truly bogus. */ + + if (*(unsigned char *)&line[0] == '%') { + s_wsfe(&io___124); + do_fio(&c__1, line, len); + e_wsfe(); + goto L13; + } + if (i__ == 1) { +/* read(line(1),'(10x,2i5)')mtrnum,mtrden */ + } else { + +/* Check for slashes (new meter change syntax) */ + + idxs = i_indx(line, "/", (ftnlen)128, (ftnlen)1); + idxb = i_indx(line, " ", (ftnlen)128, (ftnlen)1); + newmtr = idxs > 0 && (idxb == 0 || idxs < idxb); + if (! newmtr) { + +/* Old way, no slashes, uses 'o' for lonesome '1' */ + + icden = 3; + if (*(unsigned char *)&line[1] == 'o') { + mtrnum = 1; + } else { + mtrnum = *(unsigned char *)&line[1] - 48; + if (mtrnum == 1) { + icden = 4; + mtrnum = *(unsigned char *)&line[2] - 38; + } + } + mtrden = *(unsigned char *)&line[icden - 1] - 48; + } else { + +/* New way with slashes: idxs is index of 1st slash! */ + + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = idxs - 2; + ici__1.iciunit = line + 1; +/* Writing concatenation */ + i__2[0] = 2, a__2[0] = "(i"; + *(unsigned char *)&ch__1[0] = idxs + 46; + i__2[1] = 1, a__2[1] = ch__1; + i__2[2] = 1, a__2[2] = ")"; + ici__1.icifmt = (s_cat(ch__3, a__2, i__2, &c__3, (ftnlen) + 4), ch__3); + s_rsfi(&ici__1); + do_fio(&c__1, (char *)&mtrnum, (ftnlen)sizeof(integer)); + e_rsfi(); + i__3 = idxs; + idxb = i_indx(line + i__3, "/", 128 - i__3, (ftnlen)1); + i__3 = idxs; + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = idxs + idxb - 1 - i__3; + ici__1.iciunit = line + i__3; +/* Writing concatenation */ + i__2[0] = 2, a__2[0] = "(i"; + *(unsigned char *)&ch__1[0] = idxb + 47; + i__2[1] = 1, a__2[1] = ch__1; + i__2[2] = 1, a__2[2] = ")"; + ici__1.icifmt = (s_cat(ch__3, a__2, i__2, &c__3, (ftnlen) + 4), ch__3); + s_rsfi(&ici__1); + do_fio(&c__1, (char *)&mtrden, (ftnlen)sizeof(integer)); + e_rsfi(); + } + } + lenbeat = ifnodur_(&mtrden, "x", (ftnlen)1); + lenmult = 1; + if (mtrden == 2) { + lenbeat = 16; + lenmult = 2; + } + lenbar = lenmult * mtrnum * lenbeat; + fwbrsym_(&lenbar, &nwbrs, wbrsym, &lwbrs, (ftnlen)3); + } + ip1 = 0; + s_copy(line1, line, (ftnlen)128, (ftnlen)128); + i__3 = nwbrs; + for (iw = 0; iw <= i__3; ++iw) { + if (iw > 0) { + idx = ntindex_(line1, wbrsym + (iw - 1) * 3, (ftnlen)128, + lwbrs); + if (idx > 0) { + +/* Check for blank or shifted rest, discount it if it's there */ + + i__4 = idx + lwbrs - 1; + if (s_cmp(line1 + i__4, " ", idx + lwbrs - i__4, (ftnlen) + 1) != 0) { + idx = 0; + } + } + } else { + idx = ntindex_(line1, "rp", (ftnlen)128, (ftnlen)2); + +/* Check for raised rest */ + + if (idx > 0) { + i__4 = idx + 1; + if (s_cmp(line1 + i__4, " ", idx + 2 - i__4, (ftnlen)1) != + 0) { + idx = 0; + } + } + } + if (idx > 0) { + if (ip1 == 0) { + ip1 = idx; + } else { + ip1 = min(ip1,idx); + } + } +/* L3: */ + } +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = sq; + i__1[1] = 1, a__1[1] = sq; + s_cat(ch__4, a__1, i__1, &c__2, (ftnlen)2); + if (i__ < 5 || *(unsigned char *)&line[0] == '%' || s_cmp(line, ch__4, + (ftnlen)2, (ftnlen)2) == 0 || ip1 == 0) { + goto L2; + } + +/* Switch to multibar rest search mode!!! Start forward in line(1) */ + + rpfirst = s_cmp(line1 + (ip1 - 1), "rp", (ftnlen)2, (ftnlen)2) == 0; + iline = 1; + nmbr = 1; + if (rpfirst) { + lwbrsx = 2; + } else { + lwbrsx = lwbrs; + } + ipe = ip1 + lwbrsx - 1; +L4: + if (ipe == len) { + +/* Need a new line */ + + ++iline; +L6: + io___144.ciunit = *iv + 10; + i__3 = s_rsfe(&io___144); + if (i__3 != 0) { + goto L998; + } + i__3 = do_fio(&c__1, line + (iline - 1 << 7), (ftnlen)128); + if (i__3 != 0) { + goto L998; + } + i__3 = e_rsfe(); + if (i__3 != 0) { + goto L998; + } + len = lenstr_(line + (iline - 1 << 7), &c__128, (ftnlen)128); + if (*(unsigned char *)&line[(iline - 1) * 128] == '%') { + s_wsfe(&io___145); + do_fio(&c__1, "% Following comment has been moved forward", ( + ftnlen)42); + e_wsfe(); + s_wsfe(&io___146); + do_fio(&c__1, line + (iline - 1 << 7), len); + e_wsfe(); + goto L6; + } + ipe = 0; + goto L4; +L998: + +/* No more input left */ + + s_wsle(&io___147); + do_lio(&c__9, &c__1, "All done!", (ftnlen)9); + e_wsle(); + alldone = TRUE_; + ipe = 0; + --iline; + len = lenstr_(line + (iline - 1 << 7), &c__128, (ftnlen)128); + goto L4; + } else { + if (alldone) { + *(unsigned char *)sym = ' '; + } else { + +/* ipe 0) { + ipe = ipenew; + goto L4; + } else { + wbrest = FALSE_; + if (alldone) { + goto L12; + } + i__3 = nwbrs; + for (iw = 1; iw <= i__3; ++iw) { + wbrest = wbrest || s_cmp(sym, wbrsym + (iw - 1) * 3, lsym, + lwbrs) == 0; +/* L5: */ + } + wbrest = wbrest || s_cmp(sym, "r", lsym, (ftnlen)1) == 0 && + lwbrs == 2 || s_cmp(sym, "rd", lsym, (ftnlen)2) == 0 + && lwbrs == 3 || s_cmp(sym, "rp", lsym, (ftnlen)2) == + 0 || s_cmp(sym, "r", lsym, (ftnlen)1) == 0 && rpfirst; +L12: + if (wbrest) { + ipe = ipenew; + ++nmbr; + goto L4; + } else { + +/* AHA! Failed prev. test, so last symbol was *not* mbr. */ +/* It must be saved, and its starting position is ipenew-lsym+1 */ + + if (nmbr > 1) { + +/* Write stuff up to start of mbr */ + + if (ip1 > 1) { + s_wsfe(&io___152); + do_fio(&c__1, line, ip1 - 1); + e_wsfe(); + } + +/* Insert mbr symbol. Always end with a slash just in case next sym must be */ +/* at start of block. May think this causes undefined octaves, but */ +/* probably not since it's a single voice. */ + + r__1 = nmbr + .01f; + ndig = (integer) r_lg10(&r__1) + 1; + s_wsle(&io___154); + do_lio(&c__9, &c__1, "Inserting rm, iv,nmbr:", ( + ftnlen)22); + do_lio(&c__3, &c__1, (char *)&(*iv), (ftnlen)sizeof( + integer)); + do_lio(&c__3, &c__1, (char *)&nmbr, (ftnlen)sizeof( + integer)); + e_wsle(); + ci__1.cierr = 0; + ci__1.ciunit = 40; +/* Writing concatenation */ + i__2[0] = 5, a__2[0] = "(a2,i"; + *(unsigned char *)&ch__1[0] = ndig + 48; + i__2[1] = 1, a__2[1] = ch__1; + i__2[2] = 4, a__2[2] = ",a2)"; + ci__1.cifmt = (s_cat(ch__5, a__2, i__2, &c__3, ( + ftnlen)10), ch__5); + s_wsfe(&ci__1); + do_fio(&c__1, "rm", (ftnlen)2); + do_fio(&c__1, (char *)&nmbr, (ftnlen)sizeof(integer)); + do_fio(&c__1, " /", (ftnlen)2); + e_wsfe(); + if (alldone) { + goto L999; + } + ipc = ipenew - lsym + 1; + s_copy(line, line + ((iline - 1 << 7) + (ipc - 1)), ( + ftnlen)128, len - (ipc - 1)); + } else { + +/* Write old stuff up to end of original lonesome wbr, save the rest. */ +/* 4 cases: (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) , */ +/* alldone. */ +/* In 1st 2 will have gotten some other lines, so write all up to one b4 last */ +/* non-comment line; then revert to normal mode on that. In 3rd case must */ +/* split line. */ + + if (alldone) { + s_wsfe(&io___156); + do_fio(&c__1, line, len); + e_wsfe(); + goto L999; + } else if (iline > 1) { + i__3 = iline - 1; + for (il = 1; il <= i__3; ++il) { + len = lenstr_(line + (il - 1 << 7), &c__128, ( + ftnlen)128); + s_wsfe(&io___158); + do_fio(&c__1, line + (il - 1 << 7), len); + e_wsfe(); +/* L9: */ + } + s_copy(line, line + (iline - 1 << 7), (ftnlen)128, + (ftnlen)128); + } else { + +/* Since iline = 1 the wbr is not the last sym, so must split */ + + s_wsfe(&io___159); + do_fio(&c__1, line, ip1 + lwbrsx - 1); + e_wsfe(); + i__3 = ip1 + lwbrsx; + s_copy(line, line + i__3, (ftnlen)128, len - i__3) + ; + } + } + +/* Exit multibar mode */ + + goto L7; + } + } + } +L2: + if (len > 0) { + s_wsfe(&io___160); + do_fio(&c__1, line, len); + e_wsfe(); + } else { + s_wsfe(&io___161); + do_fio(&c__1, " ", (ftnlen)1); + e_wsfe(); + } +/* L1: */ + } +L999: + cl__1.cerr = 0; + cl__1.cunit = *iv + 10; + cl__1.csta = 0; + f_clos(&cl__1); + cl__1.cerr = 0; + cl__1.cunit = 40; + cl__1.csta = 0; + f_clos(&cl__1); + return 0; +} /* mbrests_ */ + +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___162 = { 0, 6, 0, 0, 0 }; + + + if (*idur == 6) { + ret_val = 1; + } else if (*idur == 3) { + ret_val = 2; + } else if (*idur == 1 || *idur == 16) { + ret_val = 4; + } else if (*idur == 8) { + ret_val = 8; + } else if (*idur == 4) { + ret_val = 16; + } else if (*idur == 2) { + ret_val = 32; + } else if (*idur == 0) { + ret_val = 64; + } else { + s_wsle(&io___162); + do_lio(&c__9, &c__1, "You entered an invalid note-length value", ( + ftnlen)40); + e_wsle(); + s_stop("", (ftnlen)0); + } + if (*(unsigned char *)dotq == 'd') { + ret_val = ret_val * 3 / 2; + } + return ret_val; +} /* ifnodur_ */ + +/* Subroutine */ int fwbrsym_(integer *lenbar, integer *nwbrs, char *wbrsym, + integer *lwbrs, ftnlen wbrsym_len) +{ + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + + /* Fortran I/O blocks */ + static cilist io___163 = { 0, 6, 0, "(33H Any whole-bar rests of duratio" + "n ,i3, 26H/64 will not be recognized)", 0 }; + + + /* Parameter adjustments */ + wbrsym -= 3; + + /* Function Body */ + *nwbrs = 1; + *lwbrs = 2; + if (*lenbar == 16) { + s_copy(wbrsym + 3, "r4", (ftnlen)3, (ftnlen)2); + } else if (*lenbar == 32) { + s_copy(wbrsym + 3, "r2", (ftnlen)3, (ftnlen)2); + } else if (*lenbar == 64) { + s_copy(wbrsym + 3, "r0", (ftnlen)3, (ftnlen)2); + } else if (*lenbar == 8) { + s_copy(wbrsym + 3, "r8", (ftnlen)3, (ftnlen)2); + } else if (*lenbar == 128) { + s_copy(wbrsym + 3, "r9", (ftnlen)3, (ftnlen)2); + } else { + *nwbrs = 2; + *lwbrs = 3; + if (*lenbar == 24) { + s_copy(wbrsym + 3, "rd4", (ftnlen)3, (ftnlen)3); + s_copy(wbrsym + 6, "r4d", (ftnlen)3, (ftnlen)3); + } else if (*lenbar == 48) { + s_copy(wbrsym + 3, "rd2", (ftnlen)3, (ftnlen)3); + s_copy(wbrsym + 6, "r2d", (ftnlen)3, (ftnlen)3); + } else if (*lenbar == 96) { + s_copy(wbrsym + 3, "rd0", (ftnlen)3, (ftnlen)3); + s_copy(wbrsym + 6, "r0d", (ftnlen)3, (ftnlen)3); + } else { + s_wsfe(&io___163); + do_fio(&c__1, (char *)&(*lenbar), (ftnlen)sizeof(integer)); + e_wsfe(); + } + } + return 0; +} /* fwbrsym_ */ + +/* Subroutine */ int nextsym_(char *line, integer *len, integer *ipeold, + integer *ipenew, char *sym, integer *lsym, ftnlen line_len, ftnlen + sym_len) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen), s_copy(char *, char *, + ftnlen, ftnlen); + + /* Local variables */ + static integer ip, iip; + + /* Fortran I/O blocks */ + static cilist io___164 = { 0, 6, 0, 0, 0 }; + static cilist io___165 = { 0, 6, 0, 0, 0 }; + static cilist io___168 = { 0, 6, 0, 0, 0 }; + + + +/* Know its the last symbol if on return ipenew = len!. So should never */ +/* be called when ipstart=len. */ + + if (*ipeold >= *len) { + s_wsle(&io___164); + do_lio(&c__9, &c__1, "Called nextsym with ipstart>=len ", (ftnlen)33); + e_wsle(); + s_wsle(&io___165); + do_lio(&c__9, &c__1, "Send files to Dr. Don at dsimons@logicon.com", ( + ftnlen)44); + e_wsle(); + s_stop("", (ftnlen)0); + } + i__1 = *len; + for (ip = *ipeold + 1; ip <= i__1; ++ip) { + if (*(unsigned char *)&line[ip - 1] != ' ') { + +/* symbol starts here (ip). We're committed to exit the loop. */ + + if (ip < *len) { + i__2 = *len; + for (iip = ip + 1; iip <= i__2; ++iip) { + if (*(unsigned char *)&line[iip - 1] != ' ') { + goto L2; + } + +/* iip is the space after the symbol */ + + *ipenew = iip - 1; + *lsym = *ipenew - ip + 1; + s_copy(sym, line + (ip - 1), (ftnlen)80, *ipenew - (ip - + 1)); + return 0; +L2: + ; + } + +/* Have len>=2 and ends on len */ + + *ipenew = *len; + *lsym = *ipenew - ip + 1; + s_copy(sym, line + (ip - 1), (ftnlen)80, *ipenew - (ip - 1)); + return 0; + } else { + +/* ip = len */ + + *ipenew = *len; + *lsym = 1; + s_copy(sym, line + (ip - 1), (ftnlen)80, (ftnlen)1); + return 0; + } + } +/* L1: */ + } + s_wsle(&io___168); + do_lio(&c__9, &c__1, "Error #3. Send files to Dr. Don at dsimons@logico" + "n.com", (ftnlen)55); + e_wsle(); + return 0; +} /* nextsym_ */ + +integer ntindex_(char *line, char *s2q, ftnlen line_len, ftnlen s2q_len) +{ + /* System generated locals */ + address a__1[2]; + integer ret_val, i__1, i__2[2], i__3; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer i_indx(char *, char *, ftnlen, ftnlen), 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_cmp(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer ic, len, ndxs2; + static char tline[128]; + static integer ndxbs; + static logical intex; + static integer ndxdq1, ndxdq2; + extern integer lenstr_(char *, integer *, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___174 = { 0, 6, 0, 0, 0 }; + + + +/* Returns index(line,s2q) if NOT in TeX string, 0 otherwise */ + + +/* print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' */ +/* print*,line(1:79) */ + + +/* Use a temporary string to store the input and test, so can zap D"..." */ + + s_copy(tline, line, (ftnlen)128, (ftnlen)128); + ndxs2 = i_indx(tline, s2q, (ftnlen)128, s2q_len); + +/* Return point below for rechecks after zapping D" " */ + +L2: + ndxbs = i_indx(tline, "\\", (ftnlen)128, (ftnlen)1); + if (ndxbs > 0) { + +/* Special check in case \ is inside D"..." */ + + ndxdq1 = i_indx(tline, "D\"", (ftnlen)128, (ftnlen)2); + +/* If the following test fails, flow out of if block; else loop up to 2. */ + + if (ndxdq1 > 0) { + +/* Find end of D"..." */ + + i__1 = ndxdq1 + 1; + ndxdq2 = ndxdq1 + 1 + i_indx(tline + i__1, "\"", 128 - i__1, ( + ftnlen)1); + if (ndxdq2 == ndxdq1 + 1) { + s_wsle(&io___174); + do_lio(&c__9, &c__1, "Something is really wierd here", ( + ftnlen)30); + e_wsle(); + s_stop("", (ftnlen)0); + } + s_copy(tline, tline, (ftnlen)128, ndxdq1 - 1); + i__1 = ndxdq2; + for (ic = ndxdq1; ic <= i__1; ++ic) { +/* Writing concatenation */ + i__2[0] = ic - 1, a__1[0] = tline; + i__2[1] = 1, a__1[1] = " "; + s_cat(tline, a__1, i__2, &c__2, (ftnlen)128); +/* L3: */ + } + i__1 = ndxdq2; +/* Writing concatenation */ + i__2[0] = ndxdq2, a__1[0] = tline; + i__2[1] = 128 - i__1, a__1[1] = line + i__1; + s_cat(tline, a__1, i__2, &c__2, (ftnlen)128); + goto L2; + } + } + if (ndxbs == 0 || ndxs2 < ndxbs) { + ret_val = ndxs2; +/* print*,'No bs, or char is left of 1st bs, ntindex:',ntindex */ + } else { + +/* There are both bs and s2q, and bs is to the left of sq2. So check bs's to */ +/* right of first: End is '\ ', start is ' \' */ + + len = lenstr_(tline, &c__128, (ftnlen)128); + intex = TRUE_; +/* print*,'intex+>',intex */ + i__1 = len; + for (ic = ndxbs + 1; ic <= i__1; ++ic) { + if (ic == ndxs2) { + if (intex) { + ret_val = 0; + i__3 = ic; + ndxs2 = i_indx(tline + i__3, s2q, len - i__3, s2q_len) + + ic; +/* print*,'ndxs2 =>',ndxs2 */ + } else { + ret_val = ndxs2; + return ret_val; + } +/* print*,'Internal exit, intex, ntindex:',intex,ntindex */ + } else /* if(complicated condition) */ { + i__3 = ic; + if (intex && s_cmp(tline + i__3, "\\ ", ic + 2 - i__3, ( + ftnlen)2) == 0) { + intex = FALSE_; +/* print*,'intex+>',intex */ + } else /* if(complicated condition) */ { + i__3 = ic; + if (! intex && s_cmp(tline + i__3, " \\", ic + 2 - i__3, ( + ftnlen)2) == 0) { + intex = TRUE_; +/* print*,'intex+>',intex */ + } + } + } +/* L1: */ + } +/* print*,'Out end of loop 1' */ + } +/* print*,'Exiting ntindex at the end???' */ + return ret_val; +} /* ntindex_ */ + +/* Subroutine */ int getchar_(char *line, integer *iccount, char *charq, + ftnlen line_len, ftnlen charq_len) +{ + /* Builtin functions */ + integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void); + + /* Fortran I/O blocks */ + static cilist io___178 = { 0, 10, 0, "(a)", 0 }; + + + +/* Gets the next character out of line*128. If pointer iccount=128 on entry, */ +/* then reads in a new line. Resets iccount to position of the new character. */ + + if (*iccount == 128) { + s_rsfe(&io___178); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + *iccount = 0; + } + ++(*iccount); + *(unsigned char *)charq = *(unsigned char *)&line[*iccount - 1]; + return 0; +} /* getchar_ */ + +doublereal readin_(char *line, integer *iccount, integer *iread, ftnlen + line_len) +{ + /* System generated locals */ + address a__1[3]; + integer i__1[3], i__2; + real ret_val; + char ch__1[27], ch__2[6], ch__3[1]; + icilist ici__1; + + /* Builtin functions */ + integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void), + 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); + /* Subroutine */ int s_stop(char *, ftnlen); + integer s_rsfi(icilist *), e_rsfi(void); + + /* Local variables */ + extern /* Subroutine */ int allparts_(char *, integer *, ftnlen); + static integer i1, i2, icf; + static char durq[1]; + extern /* Subroutine */ int chkcom_(char *, ftnlen), getchar_(char *, + integer *, char *, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___179 = { 0, 10, 0, "(a)", 0 }; + static cilist io___183 = { 0, 6, 0, 0, 0 }; + static cilist io___185 = { 0, 6, 0, 0, 0 }; + + + +/* Reads a piece of setup data from line, gets a new line from */ +/* file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. */ + +/* iread controls copying of values into scratch files for parts, but only */ +/* if not replacing. */ + +/* iread input value written */ +/* -1 nvi nothing (only used when noinst<0 initially) */ +/* 0 various value read */ +/* 1 nv -1 , replace later with nvi(i) */ +/* 2 noinst 1 */ +/* 3 np -2 , replace later with (nsyst-1)/12+1 */ +/* 4 musicsize 20 */ +/* 5 fracondent 0.05 */ + +L4: + if (*iccount == 128) { + s_rsfe(&io___179); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (all_1.replacing) { + all_1.replacing = FALSE_; + } + chkcom_(line, (ftnlen)128); + *iccount = 0; + } + ++(*iccount); + +/* Find next non-blank or end of line */ + + for (*iccount = *iccount; *iccount <= 127; ++(*iccount)) { + if (*(unsigned char *)&line[*iccount - 1] != ' ') { + goto L3; + } +/* L2: */ + } + +/* If here, need to get a new line */ + + *iccount = 128; + goto L4; +L3: + +/* iccount now points to start of number to read */ + + i1 = *iccount; +L5: + getchar_(line, iccount, durq, (ftnlen)128, (ftnlen)1); + +/* Remember that getchar first increments iccount, *then* reads a character. */ + + if (i_indx("0123456789.-", durq, (ftnlen)12, (ftnlen)1) > 0) { + goto L5; + } + i2 = *iccount - 1; + if (i2 < i1) { + s_wsle(&io___183); +/* Writing concatenation */ + i__1[0] = 7, a__1[0] = "Found \""; + i__1[1] = 1, a__1[1] = durq; + i__1[2] = 19, a__1[2] = "\" instead of number"; + s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)27); + do_lio(&c__9, &c__1, ch__1, (ftnlen)27); + e_wsle(); + s_stop("1", (ftnlen)1); + } + icf = i2 - i1 + 49; + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = i2 - (i1 - 1); + ici__1.iciunit = line + (i1 - 1); +/* Writing concatenation */ + i__1[0] = 2, a__1[0] = "(f"; + *(unsigned char *)&ch__3[0] = icf; + i__1[1] = 1, a__1[1] = ch__3; + i__1[2] = 3, a__1[2] = ".0)"; + ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)6), ch__2); + s_rsfi(&ici__1); + do_fio(&c__1, (char *)&ret_val, (ftnlen)sizeof(real)); + e_rsfi(); + if (! all_1.replacing) { + if (*iread == 0) { + i__2 = i2 - i1 + 1; + allparts_(line + (i1 - 1), &i__2, i2 - (i1 - 1)); + } else if (*iread == 1) { + allparts_("-999", &c__4, (ftnlen)4); + } else if (*iread == 2) { + allparts_("1", &c__1, (ftnlen)1); + } else if (*iread == 3) { + allparts_("-998", &c__4, (ftnlen)4); + } else if (*iread == 4) { + allparts_("20", &c__2, (ftnlen)2); + } else if (*iread == 5) { + allparts_(".05", &c__3, (ftnlen)3); + } else if (*iread != -1) { + s_wsle(&io___185); + do_lio(&c__9, &c__1, "Error with iread in readin", (ftnlen)26); + e_wsle(); + s_stop("", (ftnlen)0); + } + } + return ret_val; +} /* readin_ */ + +/* Subroutine */ int chkcom_(char *line, ftnlen line_len) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ + integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void), + i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *, + ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(void); + + /* Local variables */ + static logical clefpend; + extern /* Subroutine */ int allparts_(char *, integer *, ftnlen); + static integer j, k, ivq, idxb, idxl, idxm, idxn; + extern /* Subroutine */ int zapbl_(char *, integer *, ftnlen); + static integer iposc0; + extern integer lenstr_(char *, integer *, ftnlen); + static integer lenline; + + /* Fortran I/O blocks */ + static cilist io___186 = { 0, 10, 0, "(a)", 0 }; + static cilist io___195 = { 0, 10, 0, "(a)", 0 }; + static cilist io___198 = { 0, 0, 0, "(a)", 0 }; + static cilist io___199 = { 0, 0, 0, "(a)", 0 }; + static cilist io___200 = { 0, 10, 1, "(a)", 0 }; + + + +/* Assume that line has just been read. No need to change iccount since we only */ +/* process full lines. */ + +L1: + if (*(unsigned char *)line != '%') { + return 0; + } + +/* If here, line has some sort of comment */ + + if (*(unsigned char *)&line[1] == '%') { + if (! all_1.insetup) { + +/* Suck up a line, then flow out of "if" block to get another and loop */ + + s_rsfe(&io___186); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); +/* ++VV */ + +/* UNLESS (a) it has a score-only "M" and changes # of inst's. */ + + if (i_indx(line, "M", (ftnlen)128, (ftnlen)1) > 0) { + idxl = i_indx(line, "L", (ftnlen)128, (ftnlen)1); + idxm = i_indx(line, "M", (ftnlen)128, (ftnlen)1); + idxn = i_indx(line, "n", (ftnlen)128, (ftnlen)1); + idxb = i_indx(line, " ", (ftnlen)128, (ftnlen)1); + if (idxl < idxm && idxm < idxn && (idxb == 0 || idxn < idxb)) + { + i__1 = idxn; + all_1.noinow = *(unsigned char *)&line[i__1] - 48; + clefpend = TRUE_; + +/* Next noinow digits are original inst. #'s of new inst. set. Next noinow */ +/* char's after that are clefs */ + + all_1.nvnow = 0; + i__1 = all_1.noinow; + for (j = 1; j <= i__1; ++j) { + i__2 = idxn + 1 + j - 1; + all_1.iorig[j - 1] = *(unsigned char *)&line[i__2] - + 48; + iposc0 = idxn + 1 + all_1.noinow; + i__2 = all_1.nvi[all_1.iorig[j - 1] - 1]; + for (k = 1; k <= i__2; ++k) { + ++all_1.nvnow; +/* clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) */ + all_1.instnum[all_1.nvnow - 1] = j; + all_1.botv[all_1.nvnow - 1] = k == 1 && j != 1; +/* L25: */ + } +/* L24: */ + } + } + } + +/* or if it's "h" or "l", need to suck up one more line */ + + if (*(unsigned char *)line == 'h' && i_indx("+- ", line + 1, ( + ftnlen)3, (ftnlen)1) > 0 || *(unsigned char *)line == 'T' + || s_cmp(line, "l ", (ftnlen)2, (ftnlen)2) == 0) { + s_rsfe(&io___195); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + } + +/* 4/29/00 check for T string also */ + + } else { + +/* In setup mode. Set flag, flow out and do use following line */ + + all_1.replacing = TRUE_; + } + } else if (*(unsigned char *)&line[1] == '!') { + +/* Copy to all parts */ + + allparts_(line + 2, &c__125, (ftnlen)126); + } else { + +/* Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise */ +/* c Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise */ + + ivq = i_indx("123456789abcdefghijklmno", line + 1, (ftnlen)24, ( + ftnlen)1); + +/* Only treat as part-specific pmx line if number .le. noinst */ + + if (ivq < 1 || ivq > all_1.noinst) { + +/* Simple comment. */ + + allparts_(line, &c__128, (ftnlen)128); + } else { + +/* Instrument comment, copy only to part */ + + lenline = lenstr_(line, &c__128, (ftnlen)128); + if (lenline > 2) { + io___198.ciunit = ivq + 10; + s_wsfe(&io___198); + do_fio(&c__1, line + 2, lenline - 2); + e_wsfe(); + } else { + +/* Transferring blank line */ + + io___199.ciunit = ivq + 10; + s_wsfe(&io___199); + do_fio(&c__1, " ", (ftnlen)1); + e_wsfe(); + } + } + } + i__1 = s_rsfe(&io___200); + if (i__1 != 0) { + goto L2; + } + i__1 = do_fio(&c__1, line, (ftnlen)128); + if (i__1 != 0) { + goto L2; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L2; + } + zapbl_(line, &c__128, (ftnlen)128); + goto L1; +L2: + return 0; +} /* chkcom_ */ + +/* Subroutine */ int dosetup_(integer *iv, char *line, integer *mtrnum, + integer *mtrden, ftnlen line_len) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void), + i_nint(real *); + + /* Local variables */ + static integer ioi, noi, iset; + static real xdata; + static integer iccount; + extern /* Subroutine */ int partnum_(integer *, integer *, char *, real *, + ftnlen); + + /* Fortran I/O blocks */ + static cilist io___204 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___206 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___208 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___209 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___210 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___211 = { 0, 40, 0, "(i5)", 0 }; + static cilist io___212 = { 0, 40, 0, "(f5.2)", 0 }; + + + +/* Transfers setup data from scratch file to real one for one instrument */ +/* Data may be mixed with comments, but on entry 1st item is a number. */ +/* Write a comment when encountered, as it comes. */ +/* Write numbers one per line. */ +/* Three input data require special handling: */ +/* If not already replaced, i.e., if negative, then */ +/* iset(1) (nv) will be replaced with nvi(i) */ +/* iset(9) (npages) will be replaced with (nsyst-1)/12+1 */ +/* iset(2), if negative, will be followed by extra numbers to be transf. */ + + iccount = 0; + for (iset = 1; iset <= 12; ++iset) { + partnum_(iv, &iccount, line, &xdata, (ftnlen)128); + if (iset == 2) { + if (xdata > 0.f) { + s_wsfe(&io___204); + i__1 = (integer) (xdata + .1f); + do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsfe(); + } else { + noi = -xdata + .1f; + s_wsfe(&io___206); + do_fio(&c__1, (char *)&noi, (ftnlen)sizeof(integer)); + e_wsfe(); + i__1 = noi; + for (ioi = 1; ioi <= i__1; ++ioi) { + partnum_(iv, &iccount, line, &xdata, (ftnlen)128); + s_wsfe(&io___208); + i__2 = (integer) (xdata + .1f); + do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer)); + e_wsfe(); +/* L2: */ + } + } +/* else if (iset.ne.8 .and. xdata.lt.0) then */ + } else if (iset != 8 && iset != 5 && xdata < 0.f) { + +/* Must be either nv or npages */ + + if ((integer) (-xdata + .1f) == 999) { + +/* It's nv */ + + s_wsfe(&io___209); + do_fio(&c__1, (char *)&all_1.nvi[*iv - 1], (ftnlen)sizeof( + integer)); + e_wsfe(); + } else { + +/* npages must be computed */ + + s_wsfe(&io___210); + i__1 = (all_1.nsyst - 1) / 12 + 1; + do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsfe(); + } + } else if (iset != 7 && iset != 12) { + +/* write integer */ + + s_wsfe(&io___211); + i__1 = i_nint(&xdata); + do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsfe(); + } else { + +/* write floating number */ + + s_wsfe(&io___212); + do_fio(&c__1, (char *)&xdata, (ftnlen)sizeof(real)); + e_wsfe(); + } + if (iset == 3) { + *mtrnum = i_nint(&xdata); + } else if (iset == 4) { + *mtrden = i_nint(&xdata); + } +/* L1: */ + } + return 0; +} /* dosetup_ */ + +/* Subroutine */ int partnum_(integer *iv, integer *iccount, char *line, real + *xdata, ftnlen line_len) +{ + /* System generated locals */ + address a__1[3]; + integer i__1[3]; + char ch__1[27], ch__2[6], ch__3[1]; + icilist ici__1; + + /* Builtin functions */ + integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void), + s_wsfe(cilist *), e_wsfe(void), 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); + /* Subroutine */ int s_stop(char *, ftnlen); + integer s_rsfi(icilist *), e_rsfi(void); + + /* Local variables */ + static integer i1, i2, icf, len; + static char durq[1]; + extern integer lenstr_(char *, integer *, ftnlen); + extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen, + ftnlen); + + /* Fortran I/O blocks */ + static cilist io___213 = { 0, 0, 0, "(a)", 0 }; + static cilist io___215 = { 0, 40, 0, "(a)", 0 }; + static cilist io___219 = { 0, 6, 0, 0, 0 }; + + + +/* Simplified number parsing. Only looks for comment lines and numbers. */ + +L2: + if (*iccount == 128) { + io___213.ciunit = *iv + 10; + s_rsfe(&io___213); + do_fio(&c__1, line, (ftnlen)128); + e_rsfe(); + if (*(unsigned char *)line == '%') { + len = lenstr_(line, &c__128, (ftnlen)128); + s_wsfe(&io___215); + do_fio(&c__1, line, len); + e_wsfe(); + goto L2; + } + *iccount = 0; + } + ++(*iccount); + +/* Find next non-blank or end of line */ + + for (*iccount = *iccount; *iccount <= 127; ++(*iccount)) { + if (*(unsigned char *)&line[*iccount - 1] != ' ') { + goto L3; + } +/* L4: */ + } + +/* If here, iccount=128 and need to get a new line */ + + goto L2; +L3: + +/* iccount now points to start of number to read */ + + i1 = *iccount; +L5: + getchar_(line, iccount, durq, (ftnlen)128, (ftnlen)1); + +/* Remember that getchar first increments iccount, *then* reads a character. */ + + if (i_indx("0123456789.-", durq, (ftnlen)12, (ftnlen)1) > 0) { + goto L5; + } + i2 = *iccount - 1; + if (i2 < i1) { + s_wsle(&io___219); +/* Writing concatenation */ + i__1[0] = 7, a__1[0] = "Found \""; + i__1[1] = 1, a__1[1] = durq; + i__1[2] = 19, a__1[2] = "\" instead of number"; + s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)27); + do_lio(&c__9, &c__1, ch__1, (ftnlen)27); + e_wsle(); + s_stop("1", (ftnlen)1); + } + icf = i2 - i1 + 49; + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = i2 - (i1 - 1); + ici__1.iciunit = line + (i1 - 1); +/* Writing concatenation */ + i__1[0] = 2, a__1[0] = "(f"; + *(unsigned char *)&ch__3[0] = icf; + i__1[1] = 1, a__1[1] = ch__3; + i__1[2] = 3, a__1[2] = ".0)"; + ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)6), ch__2); + s_rsfi(&ici__1); + do_fio(&c__1, (char *)&(*xdata), (ftnlen)sizeof(real)); + e_rsfi(); + return 0; +} /* partnum_ */ + + +/* Subroutine */ int zapbl_(char *string, integer *len, ftnlen string_len) +{ + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer i__; + + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*(unsigned char *)&string[i__ - 1] == ' ') { + goto L1; + } + if (i__ == 1) { + return 0; + } + goto L2; +L1: + ; + } + +/* If line is all blank, leave it alone */ + + return 0; +L2: + s_copy(string, string + (i__ - 1), string_len, *len - (i__ - 1)); + return 0; +} /* zapbl_ */ + +/* Subroutine */ int oddquotesbefore_(char *lineq, integer *indx, logical * + yesodd, ftnlen lineq_len) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__, numdqs; + + +/* This counts number of double quotes in lineq up to position indx-1, then */ +/* sets yesodd according to whether number is odd or even */ + + numdqs = 0; + i__1 = *indx - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*(unsigned char *)&lineq[i__ - 1] == '"') { + ++numdqs; + } +/* L1: */ + } + *yesodd = numdqs % 2 == 1; + return 0; +} /* oddquotesbefore_ */ + diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f new file mode 100644 index 00000000000..c784301d046 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f @@ -0,0 +1,1619 @@ +cccccccccccccccccccccccccc +cc +cc scor2prt 7/24/11 for PMX 2.615 +cccccccccccccccccccccccccc +c This program, developed by Don Simons (dsimons@roadrunner.com), is +c part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert +c with MusiXTeX and TeX, the purpose of PMX is to allow the user to create +c high-quality typeset musical scores by including a sequence of PMX commands +c in an ASCII input file. Scor2prt is an auxiliary program that creates PMX +c input files for individual parts from the PMX input file for the score. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c +c 7/18/11 +c Start to fix up for AS..., also Ki was done a little earlier. +c 7/5/10 +c Modify Manual to explain extended hex numbering for part-specific comments +c 5/16/10 +c Extend part-specific comments for up to 24 parts (subroutine chkcom) +c Allow files 11-34 for parts +c Change file 30 to 40 +c 6/1/08 es2p +c noimax = 24 +c +c To do +c Override fracindent, musicsize? +c Deal with midbar R? +c 2/29/04 +c Check for special character being in quoted string. +c 10/20/02 PMX 2.407 +c Interpret AN[n]"[used-defined-part-file-name]" +c 1/21/02 +c Deals with rm in multiple parts. +c s2p15 +c Get right non-tex index even if there's "\" inside D"..." +c s2p14 +c 10/29/00 fix transfer to parts of negative mtrdnp +c 4/29/00 screen for "%%" followed by "T" +c Restore change from "Version 2.1a, 21 Dec" +c s2p13 +c Allow whole-bar double-whole rests. +c Bypass MIDI commands "I..." achar(10)="I" +c s2p12 +c Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla +c only taken as such if ? represents a hex digit .le. noinst, otherwise it's +c a simple comment. This lessens incompatibility. +c In subroutine mbrest, properly open parts 10-12 if needed +c s2p11 +c Ignore leading blanks +c Fix undefined linelength in mbrest at very end of comments. +c s2p10 +c Fix non-transfer of P..c" " +c Allow "%%" and "%"n anywhere +c Version 1.43 +c Fix bug with P in TeX string. +c Ignore shifted whole-bar rests when consolidating whole-bar rests +c Copy type 4 TeX into all parts. +c Deal with XB and XP. +c Permit transfer of blank line into parts +c Change staves/inst in 'M' command. +c Arbitrary staves/inst. +c Recognize m1/2/3/4 syntax. +c Enable comment and one-voice syntax in instrument names +c +c Changes since 1.1 +c Deal with saved macros. +c Revise setup readin, to admit comments. +c Do not copy 'X' into parts +c +cccccccccccccccccccccccccccccccccccccccccccccccc + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + integer*4 ludpfn(noimax) + character*1 sq,achar(10) + character*2 termsym + character*27 jobname,infileq + character*128 instrum(noimax),udpfnq(noimax) + character*128 line,holdln,templine + logical termrpt,isachar,frstln,oneof2,botv,clefpend,fexist, + * insetup,replacing,gotname,yesodd + data achar /'P','m','V','R','A','h','w','K','M','I'/ + clefpend = .false. + insetup = .true. + replacing = .false. + frstln = .true. + lenhold = 0 + sq = char(92) + print*,'This is scor2prt for PMX 2.615, 24 July 2011' + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else +c call getarg(1,jobname,idum) ! May need to replace this w/ next line + call getarg(1,jobname) + end if + ljob = lenstr(jobname,27) + if (ljob .eq. 0) then + print*,'No was jobname entered. Restart and try again.' + stop + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + stop + end if + open(10,file=jobname(1:ljob)//'.pmx') +c +c Open all instrument files now for allparts stuff. Later disgard those >nv +c + do 19 iv = 1 , noimax + iorig(iv) = iv + open(10+iv,status='SCRATCH') + ludpfn(iv) = 0 +19 continue + read(10,'(a)')line + call chkcom(line) + if (line(1:3) .eq. '---') then + call allparts(line,128) +31 read(10,'(a)')line + if (line(1:3) .ne. '---') then + call allparts(line,128) + go to 31 + end if + call allparts(line,128) + read(10,'(a)')line + call chkcom(line) + end if + iccount = 0 + nv = readin(line,iccount,1)+.1 + noinst = readin(line,iccount,2)+.1 + if (noinst .gt. 0) then + nvi(1) = nv-noinst+1 + else + noinst = 1-noinst + do 21 iinst = 1 , noinst + nvi(iinst) = readin(line,iccount,-1)+.1 +21 continue + end if + noinow = noinst + insnow = 1 +c +c ivlast is last iv in current inst. instnum(iv) is iinst for current voice. +c + ivlast = nvi(1) + do 22 iv = 1 , nv + instnum(iv) = insnow + if (iv .eq. ivlast) then + if (iv .lt. nv) botv(iv+1) = .true. +c +c The previous stmt will set botv true only for bot voice of iinst>1. It is +c used when writing termrpts, but the one in voice one is handled differently, +c so botv(1) is left .false. +c + if (insnow .lt. noinst) then + insnow = insnow+1 + ivlast = ivlast+nvi(insnow) + end if + end if +22 continue + mtrnuml = readin(line,iccount,0)+.1 + mtrdenl = readin(line,iccount,0)+.1 + mtrnmp = readin(line,iccount,0)+.1 + mtrdnp = readin(line,iccount,0)+.1 + xmtrnum0 = readin(line,iccount,0) + isig = readin(line,iccount,0)+.1 + npages = readin(line,iccount,3)+.1 + nsyst = readin(line,iccount,0)+.1 + musicsize = readin(line,iccount,4)+.1 + fracindent = readin(line,iccount,5) + if (npages .eq. 0) then + print*, + *'You entered npages=0, which means nsyst is not the total number' + print*, + *'of systems. Scor2prt has to know the total number of systems.' + print*, + *'Please set npages and nsyst to their real values.' + stop + end if +c +c Must leave insetup=.true. else could bypass ALL instrument names. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) +c +c Normally this puts pointer at start of line with 1st inst name +c Check if prior line was "%%" +c + backspace(10) + read(10,'(a)')line + if (line(1:2) .eq. '%%') backspace(10) + do 14 iv = 1 , noinst + gotname = .false. +16 read(10,'(a)') instrum(iv) + if (instrum(iv)(1:2) .eq. '%%') then + read(10,'(a)')line + go to 16 + else if (instrum(iv)(1:1) .eq. '%') then + ivq = ichar(instrum(iv)(2:2))-48 + if (ivq.ne.iv) then +c +c It's really a comment. Copy to parts, then get another trial name. +c + call allparts(instrum(iv),128) + go to 16 + else + line = instrum(iv)(3:) + instrum(iv) = line + gotname = .true. + end if + else + gotname = .true. + end if +cc +cc The following checks for macro that write original C-clef as part of +cc instrument name. See pmx.tex +cc +c if (index(instrum(iv),'namewpc') .eq. 0) then +c write(10+iv,'(a)')' ' +c else +c inm1 = index(instrum(iv),'{')+1 +c inm2 = index(instrum(iv),'}')-1 +c read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 +c write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// +c * char(iy1+49)//char(iy2+49) +c instrum(iv) = instrum(iv)(inm1:inm2) +c end if + if (.not.gotname) then + print*,'You must provide a replacement instrument name' + stop + end if + write(10+iv,'(a)')' ' +14 continue + replacing = .false. + nvnow = nv +c +c Clef string: Note insetup is still T, so "%%" will be treated specially +c + read(10,'(a)')line + call chkcom(line) + if (replacing) then +c +c If here, we have next line after "%%", containing score's clef string +c Assume all clefs are handled with instrument comments. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) + else +c +c If here, line has the clef string in it. Handle the old way +c + kvstart = 1 + kvend = nvi(1) + do 2 inst = 1 , noinst + write(10+inst,'(a'//char(48+nvi(inst))//')') + * line(kvstart:kvend) + if (inst .lt. noinst) then + kvstart = kvend+1 + kvend = kvstart+nvi(inst+1)-1 + end if +2 continue + end if + replacing = .false. + insetup = .false. +c +c *****NOTE*****This comment applies to stuff done earlier! +c Before starting the big loop, copy initial instnum and staffnum stuff +c into working values. Latter may change if noinst changes. Also make +c list of current inst nums relative to original ones. In addition to those +c below, must redo instnum(iv) and botv(iv) when we change noinst. +c +c Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! +c +18 read(10,'(a)') line + if (line(1:1) .eq. '%') then + call allparts(line,128) + go to 18 + end if + call allparts(line,128) +c +c Write instrument names. Will be blank if later part of a score. +c + if (instrum(1)(1:1) .ne. ' ') then + do 3 iv = 1 , noinst + len = lenstr(instrum(iv),79) + write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len) +3 continue + end if +c +c The big loop. Except for '%%', put all comment lines in all parts. +c Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts +c If a line starts with %!, put the rest of it in each part. +c If a line starts with %[n], put the rest of it in part [n]. +c Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. +c Assume they only come at top of block, except terminal repeat needs +c special handling. +c Check for "P"; ignore in parts. +c Check for consecutive full-bar rests; if found, replace with rm[nn] +c + iv = 1 + iinst = 1 + termrpt = .false. +4 read(10,'(a)',end=999)line + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + call zapbl(line,128) + call chkcom(line) + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + if (line(1:1) .eq. 'T') then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (line(1:2) .eq. sq//sq) then + call allparts(line,128) + go to 4 + else if (index('hl',line(1:1)).gt.0 .and. + * index(' +-',line(2:2)) .gt. 0) then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (iv .eq. 1) then + do 5 ia = 1 , 10 +24 continue + idxa = ntindex(line,achar(ia)) + isachar = idxa .gt. 0 + if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' ' +c +c 1 2 3 4 5 6 7 8 9 10 +c data achar /'P','m','V','R','A','h','w','K','M','I'/ +c + if (ia .eq. 9) isachar = + * isachar .and. line(idxa+1:idxa+1).eq.'S' + if (isachar) then +c +c Check whether character is inside a quoted string by counting +c how many quotes precede it in the line +c + + call OddQuotesBefore(line,idxa,yesodd) + if (yesodd) isachar=.false. + end if + if (isachar) then +c +c Find next blank +c + do 6 ib = idxa+1 , 128 + if (line(ib:ib) .eq. ' ') go to 7 +6 continue + print*,'Problem with "V,R,m,P,A,h,MS, or w"' + print*, + * 'Send files to Dr. Don at dsimons at roadrunner dot com' + stop 1 +7 continue +c +c Next blank is at position ib. Later, if ia=1, must check for Pc" " ; +c i.e., look for '"' between P and blank +c + if (ia .eq. 4) then +c +c Check for terminal repeat. Note if there's a term rpt, there can't be any +c others. Also, must process repeats LAST, after m's and 'V's +c + do 8 ic = ib+1 , 128 +c +c If any subsequent character on this line is neither blank nor "/", get out +c + if (index(' /',line(ic:ic)) .eq. 0) go to 9 + if (line(ic:ic) .eq. '/') then + termrpt = .true. + termsym = line(ib-2:ib-1) +c +c Process the line as if there were no "R" +c + go to 10 + end if +8 continue +c +c +++ 060812 +c If here, all chars after "R" symbol are blanks, so process the line normally, +c but only IF next line is not the M-Tx line " /" +c + read(10,'(a)')templine + if (templine(1:2) .ne. ' /') then + backspace(10) ! and flow out + else +c +c We have the M-Tx case where one line ends with R? and next is " /". Add / to the line, +c and proceed as above +c + line = line(1:ib)//'/' + lenline = lenline+2 + termrpt = .true. + termsym = line(ib-2:ib-1) + go to 10 + end if +c +++ 060812 +c + else if (ia .eq. 1) then + idxq = ntindex(line,'"') + if (idxq.gt.idxa .and. idxq.lt.ib) then +c +c Quote is between P and next blank. Find 2nd quote, starting at the blank. +c + idxq2 = ib-1+ntindex(line,'"') + if (idxq.eq.0 .or. line(idxq2+1:idxq2+1).ne.' ') then + print* + print*,'Error copying P with quotes, idxq2:',idxq2 + print*,line(1:60) + stop 1 + end if + ib = idxq2+1 + end if +c +c Do not transfer P into parts. +c + go to 12 + else if (ia .eq. 9) then +c +c Start Saving a macro. After leaving here, a symbol will be sent to all parts, +c If all on this line, set ib to end and exit normally. +c + ndxm = index(line(ib+1:128),'M') + if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then +c +c Macro ends on this line +c + ib = ib+ndxm+1 + else +c +c Save leading part of current line +c + lenhold = idxa-1 + if (lenhold .gt. 0) holdln = line(1:lenhold) +c +c Transfer rest of line +c + call allparts(line(idxa:128),129-idxa) +c +c Read next line +c +20 read(10,'(a)')line +c +c Check for comment, transfer and loop if so +c +c if (line(1:1) .eq.'%') then +23 if (line(1:1) .eq.'%') then +c call allparts(line,128) +c go to 20 + call chkcom(line) + go to 23 + end if +c +c Look for terminal ' M' +c + if (line(1:1) .eq. 'M') then + ndxm = 1 + else + ndxm = index(line,' M') + if (ndxm .gt. 0) ndxm = ndxm+1 + end if + if (ndxm .gt. 0) then +c +c Set parameters, exit normally (but later check for leading part of 1st line +c + idxa = 1 + ib = ndxm+1 + else +c +c No "M", transfer entire line, loop +c + call allparts(line,128) + go to 20 + end if + end if + else if (ia .eq. 10) then +c +c Do not transfer MIDI command into parts +c + go to 12 + else if (ia .eq. 5) then +c +c First check for "AS", but S may come after other "A" options +c + idxS = index(line(idxa+1:ib),'S') + if (idxS .gt. 0) then +c +c Get rid of the string. First check if that's all there is in A. +c + if (ib-idxa .eq. nv+2) go to 12 + line = line(1:idxa+idxS-1)//line(idxa+idxS+nv+1:ib) + end if +c +c Check for user-defined part file name. Must start in column 1 and have +c AN[n]"userfilename". +c idxa is position of "A" +c ib is position of the next blank after "A" +c Don't allow any blanks in user +c + if (line(idxa+1:idxa+1) .ne. 'N') go to 9 ! bail out + if (idxa .ne. 1) then + print* + print*, + * 'You entered "AN..." somewhere beyond first column; stopping.' + stop 1 + end if +c +c pmxa already checked for valid one- or 2-digit number, so get it +c + if (line(4:4) .eq. '"') then +c +c Single digit instrument number +c + read(line(3:3),'(i1)')iudpfn + idxstartname = 5 + else + read(line(3:4),'(i2)')iudpfn + idxstartname = 6 + end if + ludpfn(iudpfn) = index(line(idxstartname:128),'"')-1 + if (ludpfn(iudpfn) .lt. 0) then + print* + print*,'User-defined part file name must be in quotes' + stop 1 + end if + idxendname = idxstartname+ludpfn(iudpfn)-1 + udpfnq(iudpfn) = line(idxstartname:idxendname) +c +c Get a new line! +c + go to 4 + else if (ia .eq. 8) then +c +c Key change/transposition. +c If not instrument specific, copy to all parts +c + if (line(idxa+1:idxa+1).ne.'i') go to 9 +c +c Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]... +c + ibb = idxa+2 ! Starts on digit after 'i' +40 continue + read(line(ibb:ibb),'(i1)')iiinst ! 1st digit of iinst + itemp = (index('01234567890',line(ibb+1:ibb+1))) + if (itemp.gt.0) then + ibb = ibb+1 + iiinst = 10*iiinst+itemp-1 + end if + ibb = ibb+1 ! now at first +/-. Need end of 2nd number + itemp = index(line(ibb+1:ib),'i') ! Rel pos'n of next 'i' or 0 + if (itemp .gt. 0) then + iend = ibb+itemp-1 + else + iend = ib-1 + end if + write(10+iorig(iiinst),'(a)')'Ki1'//line(ibb:iend) + if (itemp .gt. 0) then + ibb = iend+2 + go to 40 + end if + go to 12 ! Remove K command from string, go to next ia + end if +9 continue + call allparts(line(idxa:ib-1),ib-idxa) +12 continue +c +c Remove the string from line +c + if (idxa .eq. 1) then + line = line(ib:128) + else + line = line(1:idxa-1)//line(ib:128) + end if + lenline = lenstr(line,128) +c +c Loop if only blanks are left +c + if (lenline .eq. 0) go to 4 +c +c Must check for multiple "I" commands, so go to just after start of ia loop +c + if (ia .eq. 10) go to 24 +c +c Tack on front part from 1st line of saved macro +c + if (lenhold .gt. 0) then + line = holdln(1:lenhold)//' '//line(1:lenline) + lenhold = 0 + end if + end if +5 continue + end if +c +c Now a special loop to deal with 'X'. If it was %[n]X..., will have been +c copied into part [n] already. If no "B" or "P", remove. If "P", just +c remove the "P" so pmxa/b will process. If "B". do nothing. +c +10 continue + nchk = 1 +13 ntinx = nchk-1+ntindex(line(nchk:),'X') + if (ntinx .gt. nchk-1) then +c +c There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. +c + if (ntinx.gt.1) then + if (line(ntinx-1:ntinx-1).ne.' ') then +c +c The X is not 1st char of PMX command. Advance starting point, loop. +c + nchk = ntinx+1 + go to 13 + end if + end if +c +c We now know the X at ntinx starts a PMX command. Find next blank +c + ib = ntinx+index(line(ntinx+1:),' ') +c +c There must be a blank to right of "X", so ib>ntinx +c +c locp = nchk-1+index(line(nchk:ib),'P') + locp = ntinx+index(line(ntinx+1:ib),'P') +c +c Did not need to use ntindex because we already know bounds of PMX command. +c +c if (locp .gt. nchk-1) then + if (locp .gt. ntinx) then +c +c Strip out the 'P' +c + templine = line(1:locp-1) + line = templine(1:locp-1)//line(locp+1:lenline) + lenline = lenline-1 + ib = ib-1 + end if + if (index(line(ntinx:ib),':').gt.0 .or. + * index(line(ntinx:ib),'S').gt.0 .or. + * index(line(ntinx:ib),'B').gt.0 .or. locp.gt.ntinx) then +c +c The X command is a shift, "Both", or "Part". Do not remove. +c + nchk = ib+1 + go to 13 + end if +c +c Remove the X command. +c + if (ntinx .eq. 1) then + if (ib .lt. lenline) then + line = line(ib+1:lenline) + else +c +c line contains ONLY the "X" command, so get a new line +c + go to 4 + end if + else + templine = line(1:ntinx-1) + if (ib .lt. lenline) then + line = templine(1:ntinx-1)//line(ib+1:lenline) + else + line = templine(1:ntinx-1) + end if + end if +c +c Recompute lenline +c + lenline = lenstr(line,128) +c +c Resume checking after location of removed command. +c + nchk = ntinx + go to 13 + end if +c +c End of loop for X-checks +c + oneof2 = ntindex(line,'//') .gt. 0 + if (termrpt .and. botv(iv) .and. frstln .and. + * line(lenline:lenline).eq.'/') then +c +c Must add a terminal repeat before the slash +c + if (oneof2) lenline = lenline-1 + if (lenline.gt.1) write(10+iorig(iinst),'(a)')line(1:lenline-1) + if (.not. oneof2) then + line = termsym//' /' + lenline = 4 + else + line = termsym//' //' + lenline = 5 + end if + end if + if (termrpt .and. frstln .and. line(lenline:lenline).eq.'/' .and. + * iv.eq.nvnow) termrpt = .false. + write(10+iorig(iinst),'(a)')line(1:lenline) + if (oneof2) then + frstln = .false. + else if (.not.frstln) then + frstln = .true. + end if +c if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then + if (ntindex(line,'/').gt.0 .and. ntindex(line,'//').eq.0) then + iv = 1+mod(iv,nvnow) + iinst = instnum(iv) + end if + go to 4 +999 continue + close(10) +c +c In the mbrest checks, must run through ALL noinst files (not just noinow) +c + do 11 iinst = 1 , noinst +ccc+++ +cc +cc Temporarily transfer entire scratch file to real file +cc +c rewind(10+iinst) +c open(40,file='s2pout'//char(48+iinst)//'.pmx') +c do 50 m = 1 , 10000 +c read(10+iinst,'(a)',end=51)line +c lenline = lenstr(line,128) +c if (lenline .ge. 1) then +c write(40,'(a)')line(1:lenline) +c else +c write(40,'(a)')' ' +c end if +c50 continue +c51 continue +c close(40) +ccc+++ + if (nvi(iinst) .eq. 1) then + call mbrests(iinst,jobname,ljob,ludpfn(iinst),udpfnq(iinst)) + else +c +c Send a signal with ljob to bypass most mbrest processing +c + call mbrests(iinst,jobname,-ljob,ludpfn(iinst),udpfnq(iinst)) + end if +11 continue + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + subroutine allparts(string,n) + parameter (noimax=24) + character*(*) string + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + len = lenstr(string,n) + if (len .eq. 0) then + len = 1 + string = ' ' + end if + do 1 iinst = 1 , noinow + write(10+iorig(iinst),'(a)')string(1:len) +1 continue + return + end + subroutine mbrests(iv,jobname,ljob,ludpfn,udpfnq) + character*128 line(50),line1,udpfnq + character*80 sym + character*12 jobname + character*3 wbrsym(2) + character*2 partq + character*1 sq + logical wbrest,alldone,rpfirst,newmtr,type4 + type4 = .false. + sq = char(92) + alldone = .false. + rewind(10+iv) +c open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') + if (iv .lt. 10) then + partq(1:1) = char(48+iv) + lpart = 1 +c +c 5/16/10 Fix for >20 parts +c +c else +c partq = '1'//char(38+iv) +c lpart = 2 + else + lpart = 2 + if (iv .lt. 20) then + partq = '1'//char(38+iv) + else + partq = '2'//char(28+iv) + end if + end if +c if (ludpfn .eq. 0) then + open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx') +c else +c open(30,file=udpfnq(1:ludpfn)//'.pmx') +c end if + do 10 i = 1 , 10000 + read(10+iv,'(a)')line(1) + if (line(1)(1:1).eq.'%' .or. line(1)(1:3).eq.'---' + * .or. type4) then + len = lenstr(line(1),128) + if (len .gt. 0) then + write(40,'(a)')line(1)(1:len) + else + write(40,'(a)')' ' + end if + if (line(1)(1:3).eq.'---') type4 = .not.type4 + else + go to 11 + end if +10 continue + print*,'You should not be here in scor2prt. Call Dr. Don' + stop +11 continue +c +c Finished reading opening type4 TeX and comments. Next line to be read +c will contain the first of the input numbers +c + call dosetup(iv,line(1),mtrnum,mtrden) + do 1 i = 1 , 10000 +13 read(10+iv,'(a)',end=999)line(1) +7 len = lenstr(line(1),128) +c +c Pass-through if instrumnet has >1 voice. +c + if (ljob .lt. 0) go to 2 + if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then +c +c Traps titles, instruments, composers, headers, lower strings. Read 2 lines. +c + write(40,'(a)')line(1)(1:len) + read(10+iv,'(a)')line(1) + len = lenstr(line(1),128) + go to 2 + end if + if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then +c +c NOTE! The above test is truly bogus. +c + if (line(1)(1:1) .eq. '%') then + write(40,'(a)')line(1)(1:len) + go to 13 + end if + if (i .eq. 1) then +c read(line(1),'(10x,2i5)')mtrnum,mtrden + else +c +c Check for slashes (new meter change syntax) +c + idxs = index(line(1),'/') + idxb = index(line(1),' ') + newmtr = idxs.gt.0 .and. (idxb.eq.0 .or. idxs.lt.idxb) + if (.not.newmtr) then +c +c Old way, no slashes, uses 'o' for lonesome '1' +c + icden = 3 + if (line(1)(2:2) .eq. 'o') then + mtrnum = 1 + else + mtrnum = ichar(line(1)(2:2))-48 + if (mtrnum .eq. 1) then + icden = 4 + mtrnum = 10+ichar(line(1)(3:3))-48 + end if + end if + mtrden = ichar(line(1)(icden:icden))-48 + else +c +c New way with slashes: idxs is index of 1st slash! +c + read(line(1)(2:idxs-1),'(i'//char(48+idxs-2)//')')mtrnum + idxb = index(line(1)(idxs+1:),'/') + read(line(1)(idxs+1:idxs+idxb-1), + * '(i'//char(48+idxb-1)//')')mtrden + end if + end if + lenbeat = ifnodur(mtrden,'x') + lenmult = 1 + if (mtrden .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnum*lenbeat + call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs) + end if + ip1 = 0 + line1 = line(1) + do 3 iw = 0 , nwbrs + if (iw .gt. 0) then + idx = ntindex(line1,wbrsym(iw)(1:lwbrs)) + if (idx .gt. 0) then +c +c Check for blank or shifted rest, discount it if it's there +c + if (line1(idx+lwbrs:idx+lwbrs).ne.' ') idx = 0 + end if + else + idx = ntindex(line1,'rp') +c +c Check for raised rest +c + if (idx.gt.0) then + if (line1(idx+2:idx+2).ne.' ') idx = 0 + end if + end if + if (idx .gt. 0) then + if (ip1 .eq. 0) then + ip1 = idx + else + ip1 = min(ip1,idx) + end if + end if +3 continue + if (i.lt.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq + * .or. ip1.eq.0) go to 2 +c +c Switch to multibar rest search mode!!! Start forward in line(1) +c + rpfirst = line1(ip1:ip1+1) .eq. 'rp' + iline = 1 + nmbr = 1 + if (rpfirst) then + lwbrsx = 2 + else + lwbrsx = lwbrs + end if + ipe = ip1+lwbrsx-1 +4 if (ipe .eq. len) then +c +c Need a new line +c + iline = iline+1 +6 read(10+iv,'(a)',end=998)line(iline) + len = lenstr(line(iline),128) + if (line(iline)(1:1).eq.'%' ) then + write(40,'(a)')'% Following comment has been moved forward' + write(40,'(a)')line(iline)(1:len) + go to 6 + end if + ipe = 0 + go to 4 +998 continue +c +c No more input left +c + print*,'All done!' + alldone = .true. + ipe = 0 + iline = iline-1 + len = lenstr(line(iline),128) + go to 4 + else + if (alldone) then + sym(1:1) = ' ' + else +c +c ipe=len ' + print*,'Send files to Dr. Don at dsimons@logicon.com' + stop + end if + do 1 ip = ipeold+1 , len + if (line(ip:ip) .ne. ' ') then +c +c symbol starts here (ip). We're committed to exit the loop. +c + if (ip .lt. len) then + do 2 iip = ip+1 , len + if (line(iip:iip) .ne. ' ') go to 2 +c +c iip is the space after the symbol +c + ipenew = iip-1 + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return +2 continue +c +c Have len>=2 and ends on len +c + ipenew = len + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return + else +c +c ip = len +c + ipenew = len + lsym = 1 + sym = line(ip:ip) + return + end if + end if +1 continue + print*,'Error #3. Send files to Dr. Don at dsimons@logicon.com' + end + function ntindex(line,s2q) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q + character*128 line,tline + logical intex +c +c print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' +c print*,line(1:79) +c +c +c Use a temporary string to store the input and test, so can zap D"..." +c + tline = line + ndxs2 = index(tline,s2q) +c +c Return point below for rechecks after zapping D" " +c +2 continue + ndxbs = index(tline,char(92)) + if (ndxbs .gt. 0) then +c +c Special check in case \ is inside D"..." +c + ndxDq1 = index(tline,'D"') +c +c If the following test fails, flow out of if block; else loop up to 2. +c + if (ndxDq1 .gt. 0) then +c +c Find end of D"..." +c + ndxDq2 = ndxDq1+1+index(tline(ndxDq1+2:128),'"') + if (ndxDq2 .eq. ndxDq1+1) then + print*,'Something is really wierd here' + stop + end if + tline = tline(1:ndxDq1-1) + do 3 ic = ndxDq1 , ndxDq2 + tline = tline(1:ic-1)//' ' +3 continue + tline = tline(1:ndxDq2)//line(ndxDq2+1:128) + go to 2 + end if + end if + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 +c print*,'No bs, or char is left of 1st bs, ntindex:',ntindex + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(tline,128) + intex = .true. +c print*,'intex+>',intex + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(tline(ic+1:len),s2q)+ic +c print*,'ndxs2 =>',ndxs2 + else + ntindex = ndxs2 + return + end if +c print*,'Internal exit, intex, ntindex:',intex,ntindex + else if (intex .and. tline(ic+1:ic+2).eq.char(92)//' ') then + intex = .false. +c print*,'intex+>',intex + else if (.not.intex .and. tline(ic+1:ic+2).eq.' '//char(92)) + * then + intex = .true. +c print*,'intex+>',intex + end if +1 continue +c print*,'Out end of loop 1' + end if +c print*,'Exiting ntindex at the end???' + return + end + subroutine getchar(line,iccount,charq) +c +c Gets the next character out of line*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount to position of the new character. +c + character*1 charq + character*128 line + if (iccount .eq. 128) then + read(10,'(a)')line + iccount = 0 + end if + iccount = iccount+1 + charq = line(iccount:iccount) + return + end + function readin(line,iccount,iread) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv +c +c Reads a piece of setup data from line, gets a new line from +c file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. +c +c iread controls copying of values into scratch files for parts, but only +c if not replacing. +c +c iread input value written +c -1 nvi nothing (only used when noinst<0 initially) +c 0 various value read +c 1 nv -1 , replace later with nvi(i) +c 2 noinst 1 +c 3 np -2 , replace later with (nsyst-1)/12+1 +c 4 musicsize 20 +c 5 fracondent 0.05 +c + character*128 line + character*1 durq +4 if (iccount .eq. 128) then + read(10,'(a)')line + if (replacing) replacing = .false. + call chkcom(line) + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')readin + if (.not.replacing) then + if (iread .eq. 0) then + call allparts(line(i1:i2),i2-i1+1) + else if (iread .eq. 1) then + call allparts('-999',4) + else if (iread .eq. 2) then + call allparts('1',1) + else if (iread .eq. 3) then + call allparts('-998',4) + else if (iread .eq. 4) then + call allparts('20',2) + else if (iread .eq. 5) then + call allparts('.05',3) + else if (iread .ne. -1) then + print*,'Error with iread in readin' + stop + end if + end if + return + end + subroutine chkcom(line) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,clefpend,botv + character*128 line +c +c Assume that line has just been read. No need to change iccount since we only +c process full lines. +c +1 if (line(1:1) .ne. '%') return +c +c If here, line has some sort of comment +c + if (line(2:2) .eq. '%') then + if (.not. insetup) then +c +c Suck up a line, then flow out of "if" block to get another and loop +c + read(10,'(a)')line + +c++VV +c +c UNLESS (a) it has a score-only "M" and changes # of inst's. +c + if (index(line,'M') .gt. 0) then + idxL = index(line,'L') + idxM = index(line,'M') + idxn = index(line,'n') + idxb = index(line,' ') + if (idxL.lt.idxM .and. idxM.lt.idxn .and. + * (idxb.eq.0 .or. idxn.lt.idxb)) then + noinow = ichar(line(idxn+1:idxn+1))-48 + clefpend = .true. +c +c Next noinow digits are original inst. #'s of new inst. set. Next noinow +c char's after that are clefs +c + nvnow = 0 + do 24 j = 1 , noinow + iorig(j) = ichar(line(idxn+1+j:idxn+1+j))-48 + iposc0 = idxn+1+noinow + do 25 k = 1 , nvi(iorig(j)) + nvnow = nvnow+1 +c clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) + instnum(nvnow) = j + botv(nvnow) = k.eq.1 .and. j.ne.1 +25 continue +24 continue + end if + end if +c +c or if it's "h" or "l", need to suck up one more line +c + if ((line(1:1).eq.'h'.and.index('+- ',line(2:2)).gt.0) .or. +c +c 4/29/00 check for T string also +c + * line(1:1).eq.'T' .or. + * line(1:2).eq.'l ') read(10,'(a)')line + else +c +c In setup mode. Set flag, flow out and do use following line +c + replacing = .true. + end if + else if (line(2:2) .eq. '!') then +c +c Copy to all parts +c + call allparts(line(3:128),125) + else +c +c Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise +cc Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise +c + ivq = index('123456789abcdefghijklmno',line(2:2)) +c +c Only treat as part-specific pmx line if number .le. noinst +c + if (ivq.lt.1 .or. ivq.gt.noinst) then +c +c Simple comment. +c + call allparts(line,128) + else +c +c Instrument comment, copy only to part +c + lenline = lenstr(line,128) + if (lenline .gt. 2) then + write(10+ivq,'(a)')line(3:lenline) + else +c +c Transferring blank line +c + write(10+ivq,'(a)')' ' + end if + end if + end if + read(10,'(a)',end=2)line + call zapbl(line,128) + go to 1 +2 continue + return + end + subroutine dosetup(iv,line,mtrnum,mtrden) + parameter (noimax=24) +c +c Transfers setup data from scratch file to real one for one instrument +c Data may be mixed with comments, but on entry 1st item is a number. +c Write a comment when encountered, as it comes. +c Write numbers one per line. +c Three input data require special handling: +c If not already replaced, i.e., if negative, then +c iset(1) (nv) will be replaced with nvi(i) +c iset(9) (npages) will be replaced with (nsyst-1)/12+1 +c iset(2), if negative, will be followed by extra numbers to be transf. +c + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + character*128 line + iccount = 0 + do 1 iset = 1 , 12 + call partnum(iv,iccount,line,xdata) + if (iset .eq. 2) then + if (xdata .gt. 0) then + write(40,'(i5)')int(xdata+.1) + else + noi = -xdata+.1 + write(40,'(i5)')noi + do 2 ioi = 1 , noi + call partnum(iv,iccount,line,xdata) + write(40,'(i5)')int(xdata+.1) +2 continue + end if +c else if (iset.ne.8 .and. xdata.lt.0) then + else if (iset.ne.8 .and. iset.ne.5 .and. xdata.lt.0) then +c +c Must be either nv or npages +c + if (int(-xdata+.1) .eq. 999) then +c +c It's nv +c + write(40,'(i5)')nvi(iv) + else +c +c npages must be computed +c + write(40,'(i5)')(nsyst-1)/12+1 + end if + else if (iset.ne.7 .and. iset.ne.12) then +c +c write integer +c + write(40,'(i5)')nint(xdata) + else +c +c write floating number +c + write(40,'(f5.2)')xdata + end if + if (iset .eq. 3) then + mtrnum = nint(xdata) + else if (iset .eq. 4) then + mtrden = nint(xdata) + end if +1 continue + return + end + subroutine partnum(iv,iccount,line,xdata) +c +c Simplified number parsing. Only looks for comment lines and numbers. +c + character*128 line + character*1 durq +2 if (iccount .eq. 128) then + read(10+iv,'(a)')line + if (line(1:1) .eq. '%') then + len = lenstr(line,128) + write(40,'(a)')line(1:len) + go to 2 + end if + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 4 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +4 continue +c +c If here, iccount=128 and need to get a new line +c + go to 2 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')xdata + return + end + block data + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + data nvi /noimax*1/, noinst,noinow /2*noimax/ + data botv /noimax*.false./ + end + subroutine zapbl(string,len) + character*(*) string + do 1 i = 1 , len + if (string(i:i) .eq. ' ')go to 1 + if (i .eq. 1) return + go to 2 +1 continue +c +c If line is all blank, leave it alone +c + return +2 continue + string = string(i:len) + return + end + subroutine OddQuotesBefore(lineq,indx,yesodd) +c +c This counts number of double quotes in lineq up to position indx-1, then +c sets yesodd according to whether number is odd or even +c + logical yesodd + character*(*) lineq + numdqs = 0 + do 1 i = 1 , indx-1 + if (lineq(i:i) .eq. '"') numdqs = numdqs+1 +1 continue + yesodd = mod(numdqs,2) .eq. 1 + return + end + + + + + diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for new file mode 100644 index 00000000000..99fe18e4cab --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for @@ -0,0 +1,1620 @@ +cccccccccccccccccccccccccc +cc +cc scor2prt 7/24/11 for PMX 2.615 +cccccccccccccccccccccccccc +c This program, developed by Don Simons (dsimons@roadrunner.com), is +c part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert +c with MusiXTeX and TeX, the purpose of PMX is to allow the user to create +c high-quality typeset musical scores by including a sequence of PMX commands +c in an ASCII input file. Scor2prt is an auxiliary program that creates PMX +c input files for individual parts from the PMX input file for the score. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c +c 7/18/11 +c Start to fix up for AS..., also Ki was done a little earlier. +c 7/5/10 +c Modify Manual to explain extended hex numbering for part-specific comments +c 5/16/10 +c Extend part-specific comments for up to 24 parts (subroutine chkcom) +c Allow files 11-34 for parts +c Change file 30 to 40 +c 6/1/08 es2p +c noimax = 24 +c +c To do +c Override fracindent, musicsize? +c Deal with midbar R? +c 2/29/04 +c Check for special character being in quoted string. +c 10/20/02 PMX 2.407 +c Interpret AN[n]"[used-defined-part-file-name]" +c 1/21/02 +c Deals with rm in multiple parts. +c s2p15 +c Get right non-tex index even if there's "\" inside D"..." +c s2p14 +c 10/29/00 fix transfer to parts of negative mtrdnp +c 4/29/00 screen for "%%" followed by "T" +c Restore change from "Version 2.1a, 21 Dec" +c s2p13 +c Allow whole-bar double-whole rests. +c Bypass MIDI commands "I..." achar(10)="I" +c s2p12 +c Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla +c only taken as such if ? represents a hex digit .le. noinst, otherwise it's +c a simple comment. This lessens incompatibility. +c In subroutine mbrest, properly open parts 10-12 if needed +c s2p11 +c Ignore leading blanks +c Fix undefined linelength in mbrest at very end of comments. +c s2p10 +c Fix non-transfer of P..c" " +c Allow "%%" and "%"n anywhere +c Version 1.43 +c Fix bug with P in TeX string. +c Ignore shifted whole-bar rests when consolidating whole-bar rests +c Copy type 4 TeX into all parts. +c Deal with XB and XP. +c Permit transfer of blank line into parts +c Change staves/inst in 'M' command. +c Arbitrary staves/inst. +c Recognize m1/2/3/4 syntax. +c Enable comment and one-voice syntax in instrument names +c +c Changes since 1.1 +c Deal with saved macros. +c Revise setup readin, to admit comments. +c Do not copy 'X' into parts +c +cccccccccccccccccccccccccccccccccccccccccccccccc + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + integer*4 ludpfn(noimax) + character*1 sq,achar(10) + character*2 termsym + character*27 jobname,infileq + character*128 instrum(noimax),udpfnq(noimax) + character*128 line,holdln,templine + logical termrpt,isachar,frstln,oneof2,botv,clefpend,fexist, + * insetup,replacing,gotname,yesodd + data achar /'P','m','V','R','A','h','w','K','M','I'/ + clefpend = .false. + insetup = .true. + replacing = .false. + frstln = .true. + lenhold = 0 + sq = char(92) + print*,'This is scor2prt for PMX 2.615, 24 July 2011' + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else +c call getarg(1,jobname,idum) ! May need to replace this w/ next line + call getarg(1,jobname) + end if + ljob = lenstr(jobname,27) + if (ljob .eq. 0) then + print*,'No was jobname entered. Restart and try again.' + stop + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + stop + end if + open(10,file=jobname(1:ljob)//'.pmx') +c +c Open all instrument files now for allparts stuff. Later disgard those >nv +c + do 19 iv = 1 , noimax + iorig(iv) = iv + open(10+iv,status='SCRATCH') + ludpfn(iv) = 0 +19 continue + read(10,'(a)')line + call chkcom(line) + if (line(1:3) .eq. '---') then + call allparts(line,128) +31 read(10,'(a)')line + if (line(1:3) .ne. '---') then + call allparts(line,128) + go to 31 + end if + call allparts(line,128) + read(10,'(a)')line + call chkcom(line) + end if + iccount = 0 + nv = readin(line,iccount,1)+.1 + noinst = readin(line,iccount,2)+.1 + if (noinst .gt. 0) then + nvi(1) = nv-noinst+1 + else + noinst = 1-noinst + do 21 iinst = 1 , noinst + nvi(iinst) = readin(line,iccount,-1)+.1 +21 continue + end if + noinow = noinst + insnow = 1 +c +c ivlast is last iv in current inst. instnum(iv) is iinst for current voice. +c + ivlast = nvi(1) + do 22 iv = 1 , nv + instnum(iv) = insnow + if (iv .eq. ivlast) then + if (iv .lt. nv) botv(iv+1) = .true. +c +c The previous stmt will set botv true only for bot voice of iinst>1. It is +c used when writing termrpts, but the one in voice one is handled differently, +c so botv(1) is left .false. +c + if (insnow .lt. noinst) then + insnow = insnow+1 + ivlast = ivlast+nvi(insnow) + end if + end if +22 continue + mtrnuml = readin(line,iccount,0)+.1 + mtrdenl = readin(line,iccount,0)+.1 + mtrnmp = readin(line,iccount,0)+.1 + mtrdnp = readin(line,iccount,0)+.1 + xmtrnum0 = readin(line,iccount,0) + isig = readin(line,iccount,0)+.1 + npages = readin(line,iccount,3)+.1 + nsyst = readin(line,iccount,0)+.1 + musicsize = readin(line,iccount,4)+.1 + fracindent = readin(line,iccount,5) + if (npages .eq. 0) then + print*, + *'You entered npages=0, which means nsyst is not the total number' + print*, + *'of systems. Scor2prt has to know the total number of systems.' + print*, + *'Please set npages and nsyst to their real values.' + stop + end if +c +c Must leave insetup=.true. else could bypass ALL instrument names. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) +c +c Normally this puts pointer at start of line with 1st inst name +c Check if prior line was "%%" +c + backspace(10) + read(10,'(a)')line + if (line(1:2) .eq. '%%') backspace(10) + do 14 iv = 1 , noinst + gotname = .false. +16 read(10,'(a)') instrum(iv) + if (instrum(iv)(1:2) .eq. '%%') then + read(10,'(a)')line + go to 16 + else if (instrum(iv)(1:1) .eq. '%') then + ivq = ichar(instrum(iv)(2:2))-48 + if (ivq.ne.iv) then +c +c It's really a comment. Copy to parts, then get another trial name. +c + call allparts(instrum(iv),128) + go to 16 + else + line = instrum(iv)(3:) + instrum(iv) = line + gotname = .true. + end if + else + gotname = .true. + end if +cc +cc The following checks for macro that write original C-clef as part of +cc instrument name. See pmx.tex +cc +c if (index(instrum(iv),'namewpc') .eq. 0) then +c write(10+iv,'(a)')' ' +c else +c inm1 = index(instrum(iv),'{')+1 +c inm2 = index(instrum(iv),'}')-1 +c read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 +c write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// +c * char(iy1+49)//char(iy2+49) +c instrum(iv) = instrum(iv)(inm1:inm2) +c end if + if (.not.gotname) then + print*,'You must provide a replacement instrument name' + stop + end if + write(10+iv,'(a)')' ' +14 continue + replacing = .false. + nvnow = nv +c +c Clef string: Note insetup is still T, so "%%" will be treated specially +c + read(10,'(a)')line + call chkcom(line) + if (replacing) then +c +c If here, we have next line after "%%", containing score's clef string +c Assume all clefs are handled with instrument comments. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) + else +c +c If here, line has the clef string in it. Handle the old way +c + kvstart = 1 + kvend = nvi(1) + do 2 inst = 1 , noinst + write(10+inst,'(a'//char(48+nvi(inst))//')') + * line(kvstart:kvend) + if (inst .lt. noinst) then + kvstart = kvend+1 + kvend = kvstart+nvi(inst+1)-1 + end if +2 continue + end if + replacing = .false. + insetup = .false. +c +c *****NOTE*****This comment applies to stuff done earlier! +c Before starting the big loop, copy initial instnum and staffnum stuff +c into working values. Latter may change if noinst changes. Also make +c list of current inst nums relative to original ones. In addition to those +c below, must redo instnum(iv) and botv(iv) when we change noinst. +c +c Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! +c +18 read(10,'(a)') line + if (line(1:1) .eq. '%') then + call allparts(line,128) + go to 18 + end if + call allparts(line,128) +c +c Write instrument names. Will be blank if later part of a score. +c + if (instrum(1)(1:1) .ne. ' ') then + do 3 iv = 1 , noinst + len = lenstr(instrum(iv),79) + write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len) +3 continue + end if +c +c The big loop. Except for '%%', put all comment lines in all parts. +c Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts +c If a line starts with %!, put the rest of it in each part. +c If a line starts with %[n], put the rest of it in part [n]. +c Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. +c Assume they only come at top of block, except terminal repeat needs +c special handling. +c Check for "P"; ignore in parts. +c Check for consecutive full-bar rests; if found, replace with rm[nn] +c + iv = 1 + iinst = 1 + termrpt = .false. +4 read(10,'(a)',end=999)line + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + call zapbl(line,128) + call chkcom(line) + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + if (line(1:1) .eq. 'T') then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (line(1:2) .eq. sq//sq) then + call allparts(line,128) + go to 4 + else if (index('hl',line(1:1)).gt.0 .and. + * index(' +-',line(2:2)) .gt. 0) then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (iv .eq. 1) then + do 5 ia = 1 , 10 +24 continue + idxa = ntindex(line,achar(ia)) + isachar = idxa .gt. 0 + if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' ' +c +c 1 2 3 4 5 6 7 8 9 10 +c data achar /'P','m','V','R','A','h','w','K','M','I'/ +c + if (ia .eq. 9) isachar = + * isachar .and. line(idxa+1:idxa+1).eq.'S' + if (isachar) then +c +c Check whether character is inside a quoted string by counting +c how many quotes precede it in the line +c + + call OddQuotesBefore(line,idxa,yesodd) + if (yesodd) isachar=.false. + end if + if (isachar) then +c +c Find next blank +c + do 6 ib = idxa+1 , 128 + if (line(ib:ib) .eq. ' ') go to 7 +6 continue + print*,'Problem with "V,R,m,P,A,h,MS, or w"' + print*, + * 'Send files to Dr. Don at dsimons at roadrunner dot com' + stop 1 +7 continue +c +c Next blank is at position ib. Later, if ia=1, must check for Pc" " ; +c i.e., look for '"' between P and blank +c + if (ia .eq. 4) then +c +c Check for terminal repeat. Note if there's a term rpt, there can't be any +c others. Also, must process repeats LAST, after m's and 'V's +c + do 8 ic = ib+1 , 128 +c +c If any subsequent character on this line is neither blank nor "/", get out +c + if (index(' /',line(ic:ic)) .eq. 0) go to 9 + if (line(ic:ic) .eq. '/') then + termrpt = .true. + termsym = line(ib-2:ib-1) +c +c Process the line as if there were no "R" +c + go to 10 + end if +8 continue +c +c +++ 060812 +c If here, all chars after "R" symbol are blanks, so process the line normally, +c but only IF next line is not the M-Tx line " /" +c + read(10,'(a)')templine + if (templine(1:2) .ne. ' /') then + backspace(10) ! and flow out + else +c +c We have the M-Tx case where one line ends with R? and next is " /". Add / to the line, +c and proceed as above +c + line = line(1:ib)//'/' + lenline = lenline+2 + termrpt = .true. + termsym = line(ib-2:ib-1) + go to 10 + end if +c +++ 060812 +c + else if (ia .eq. 1) then + idxq = ntindex(line,'"') + if (idxq.gt.idxa .and. idxq.lt.ib) then +c +c Quote is between P and next blank. Find 2nd quote, starting at the blank. +c + idxq2 = ib-1+ntindex(line,'"') + if (idxq.eq.0 .or. line(idxq2+1:idxq2+1).ne.' ') then + print* + print*,'Error copying P with quotes, idxq2:',idxq2 + print*,line(1:60) + stop 1 + end if + ib = idxq2+1 + end if +c +c Do not transfer P into parts. +c + go to 12 + else if (ia .eq. 9) then +c +c Start Saving a macro. After leaving here, a symbol will be sent to all parts, +c If all on this line, set ib to end and exit normally. +c + ndxm = index(line(ib+1:128),'M') + if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then +c +c Macro ends on this line +c + ib = ib+ndxm+1 + else +c +c Save leading part of current line +c + lenhold = idxa-1 + if (lenhold .gt. 0) holdln = line(1:lenhold) +c +c Transfer rest of line +c + call allparts(line(idxa:128),129-idxa) +c +c Read next line +c +20 read(10,'(a)')line +c +c Check for comment, transfer and loop if so +c +c if (line(1:1) .eq.'%') then +23 if (line(1:1) .eq.'%') then +c call allparts(line,128) +c go to 20 + call chkcom(line) + go to 23 + end if +c +c Look for terminal ' M' +c + if (line(1:1) .eq. 'M') then + ndxm = 1 + else + ndxm = index(line,' M') + if (ndxm .gt. 0) ndxm = ndxm+1 + end if + if (ndxm .gt. 0) then +c +c Set parameters, exit normally (but later check for leading part of 1st line +c + idxa = 1 + ib = ndxm+1 + else +c +c No "M", transfer entire line, loop +c + call allparts(line,128) + go to 20 + end if + end if + else if (ia .eq. 10) then +c +c Do not transfer MIDI command into parts +c + go to 12 + else if (ia .eq. 5) then +c +c First check for "AS", but S may come after other "A" options +c + idxS = index(line(idxa+1:ib),'S') + if (idxS .gt. 0) then +c +c Get rid of the string. First check if that's all there is in A. +c + if (ib-idxa .eq. nv+2) go to 12 + line = line(1:idxa+idxS-1)//line(idxa+idxS+nv+1:ib) + end if +c +c Check for user-defined part file name. Must start in column 1 and have +c AN[n]"userfilename". +c idxa is position of "A" +c ib is position of the next blank after "A" +c Don't allow any blanks in user +c + if (line(idxa+1:idxa+1) .ne. 'N') go to 9 ! bail out + if (idxa .ne. 1) then + print* + print*, + * 'You entered "AN..." somewhere beyond first column; stopping.' + stop 1 + end if +c +c pmxa already checked for valid one- or 2-digit number, so get it +c + if (line(4:4) .eq. '"') then +c +c Single digit instrument number +c + read(line(3:3),'(i1)')iudpfn + idxstartname = 5 + else + read(line(3:4),'(i2)')iudpfn + idxstartname = 6 + end if + ludpfn(iudpfn) = index(line(idxstartname:128),'"')-1 + if (ludpfn(iudpfn) .lt. 0) then + print* + print*,'User-defined part file name must be in quotes' + stop 1 + end if + idxendname = idxstartname+ludpfn(iudpfn)-1 + udpfnq(iudpfn) = line(idxstartname:idxendname) +c +c Get a new line! +c + go to 4 + else if (ia .eq. 8) then +c +c Key change/transposition. +c If not instrument specific, copy to all parts +c + if (line(idxa+1:idxa+1).ne.'i') go to 9 +c +c Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]... +c + ibb = idxa+2 ! Starts on digit after 'i' +40 continue + read(line(ibb:ibb),'(i1)')iiinst ! 1st digit of iinst + itemp = (index('01234567890',line(ibb+1:ibb+1))) + if (itemp.gt.0) then + ibb = ibb+1 + iiinst = 10*iiinst+itemp-1 + end if + ibb = ibb+1 ! now at first +/-. Need end of 2nd number + itemp = index(line(ibb+1:ib),'i') ! Rel pos'n of next 'i' or 0 + if (itemp .gt. 0) then + iend = ibb+itemp-1 + else + iend = ib-1 + end if + write(10+iorig(iiinst),'(a)')'Ki1'//line(ibb:iend) + if (itemp .gt. 0) then + ibb = iend+2 + go to 40 + end if + go to 12 ! Remove K command from string, go to next ia + end if +9 continue + call allparts(line(idxa:ib-1),ib-idxa) +12 continue +c +c Remove the string from line +c + if (idxa .eq. 1) then + line = line(ib:128) + else + line = line(1:idxa-1)//line(ib:128) + end if + lenline = lenstr(line,128) +c +c Loop if only blanks are left +c + if (lenline .eq. 0) go to 4 +c +c Must check for multiple "I" commands, so go to just after start of ia loop +c + if (ia .eq. 10) go to 24 +c +c Tack on front part from 1st line of saved macro +c + if (lenhold .gt. 0) then + line = holdln(1:lenhold)//' '//line(1:lenline) + lenhold = 0 + end if + end if +5 continue + end if +c +c Now a special loop to deal with 'X'. If it was %[n]X..., will have been +c copied into part [n] already. If no "B" or "P", remove. If "P", just +c remove the "P" so pmxa/b will process. If "B". do nothing. +c +10 continue + nchk = 1 +13 ntinx = nchk-1+ntindex(line(nchk:),'X') + if (ntinx .gt. nchk-1) then +c +c There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. +c + if (ntinx.gt.1) then + if (line(ntinx-1:ntinx-1).ne.' ') then +c +c The X is not 1st char of PMX command. Advance starting point, loop. +c + nchk = ntinx+1 + go to 13 + end if + end if +c +c We now know the X at ntinx starts a PMX command. Find next blank +c + ib = ntinx+index(line(ntinx+1:),' ') +c +c There must be a blank to right of "X", so ib>ntinx +c +c locp = nchk-1+index(line(nchk:ib),'P') + locp = ntinx+index(line(ntinx+1:ib),'P') +c +c Did not need to use ntindex because we already know bounds of PMX command. +c +c if (locp .gt. nchk-1) then + if (locp .gt. ntinx) then +c +c Strip out the 'P' +c + templine = line(1:locp-1) + line = templine(1:locp-1)//line(locp+1:lenline) + lenline = lenline-1 + ib = ib-1 + end if + if (index(line(ntinx:ib),':').gt.0 .or. + * index(line(ntinx:ib),'S').gt.0 .or. + * index(line(ntinx:ib),'B').gt.0 .or. locp.gt.ntinx) then +c +c The X command is a shift, "Both", or "Part". Do not remove. +c + nchk = ib+1 + go to 13 + end if +c +c Remove the X command. +c + if (ntinx .eq. 1) then + if (ib .lt. lenline) then + line = line(ib+1:lenline) + else +c +c line contains ONLY the "X" command, so get a new line +c + go to 4 + end if + else + templine = line(1:ntinx-1) + if (ib .lt. lenline) then + line = templine(1:ntinx-1)//line(ib+1:lenline) + else + line = templine(1:ntinx-1) + end if + end if +c +c Recompute lenline +c + lenline = lenstr(line,128) +c +c Resume checking after location of removed command. +c + nchk = ntinx + go to 13 + end if +c +c End of loop for X-checks +c + oneof2 = ntindex(line,'//') .gt. 0 + if (termrpt .and. botv(iv) .and. frstln .and. + * line(lenline:lenline).eq.'/') then +c +c Must add a terminal repeat before the slash +c + if (oneof2) lenline = lenline-1 + if (lenline.gt.1) write(10+iorig(iinst),'(a)')line(1:lenline-1) + if (.not. oneof2) then + line = termsym//' /' + lenline = 4 + else + line = termsym//' //' + lenline = 5 + end if + end if + if (termrpt .and. frstln .and. line(lenline:lenline).eq.'/' .and. + * iv.eq.nvnow) termrpt = .false. + write(10+iorig(iinst),'(a)')line(1:lenline) + if (oneof2) then + frstln = .false. + else if (.not.frstln) then + frstln = .true. + end if +c if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then + if (ntindex(line,'/').gt.0 .and. ntindex(line,'//').eq.0) then + iv = 1+mod(iv,nvnow) + iinst = instnum(iv) + end if + go to 4 +999 continue + close(10) +c +c In the mbrest checks, must run through ALL noinst files (not just noinow) +c + do 11 iinst = 1 , noinst +ccc+++ +cc +cc Temporarily transfer entire scratch file to real file +cc +c rewind(10+iinst) +c open(40,file='s2pout'//char(48+iinst)//'.pmx') +c do 50 m = 1 , 10000 +c read(10+iinst,'(a)',end=51)line +c lenline = lenstr(line,128) +c if (lenline .ge. 1) then +c write(40,'(a)')line(1:lenline) +c else +c write(40,'(a)')' ' +c end if +c50 continue +c51 continue +c close(40) +ccc+++ + if (nvi(iinst) .eq. 1) then + call mbrests(iinst,jobname,ljob,ludpfn(iinst),udpfnq(iinst)) + else +c +c Send a signal with ljob to bypass most mbrest processing +c + call mbrests(iinst,jobname,-ljob,ludpfn(iinst),udpfnq(iinst)) + end if +11 continue + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + subroutine allparts(string,n) + parameter (noimax=24) + character*(*) string + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + len = lenstr(string,n) + if (len .eq. 0) then + len = 1 + string = ' ' + end if + do 1 iinst = 1 , noinow + write(10+iorig(iinst),'(a)')string(1:len) +1 continue + return + end + subroutine mbrests(iv,jobname,ljob,ludpfn,udpfnq) + character*128 line(50),line1,udpfnq + character*80 sym + character*12 jobname + character*3 wbrsym(2) + character*2 partq + character*1 sq + logical wbrest,alldone,rpfirst,newmtr,type4 + type4 = .false. + sq = char(92) + alldone = .false. + rewind(10+iv) +c open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') + if (iv .lt. 10) then + partq(1:1) = char(48+iv) + lpart = 1 +c +c 5/16/10 Fix for >20 parts +c +c else +c partq = '1'//char(38+iv) +c lpart = 2 + else + lpart = 2 + if (iv .lt. 20) then + partq = '1'//char(38+iv) + else + partq = '2'//char(28+iv) + end if + end if +c if (ludpfn .eq. 0) then + open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx') +c else +c open(30,file=udpfnq(1:ludpfn)//'.pmx') +c end if + do 10 i = 1 , 10000 + read(10+iv,'(a)')line(1) + if (line(1)(1:1).eq.'%' .or. line(1)(1:3).eq.'---' + * .or. type4) then + len = lenstr(line(1),128) + if (len .gt. 0) then + write(40,'(a)')line(1)(1:len) + else + write(40,'(a)')' ' + end if + if (line(1)(1:3).eq.'---') type4 = .not.type4 + else + go to 11 + end if +10 continue + print*,'You should not be here in scor2prt. Call Dr. Don' + stop +11 continue +c +c Finished reading opening type4 TeX and comments. Next line to be read +c will contain the first of the input numbers +c + call dosetup(iv,line(1),mtrnum,mtrden) + do 1 i = 1 , 10000 +13 read(10+iv,'(a)',end=999)line(1) +7 len = lenstr(line(1),128) +c +c Pass-through if instrumnet has >1 voice. +c + if (ljob .lt. 0) go to 2 + if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then +c +c Traps titles, instruments, composers, headers, lower strings. Read 2 lines. +c + write(40,'(a)')line(1)(1:len) + read(10+iv,'(a)')line(1) + len = lenstr(line(1),128) + go to 2 + end if + if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then +c +c NOTE! The above test is truly bogus. +c + if (line(1)(1:1) .eq. '%') then + write(40,'(a)')line(1)(1:len) + go to 13 + end if + if (i .eq. 1) then +c read(line(1),'(10x,2i5)')mtrnum,mtrden + else +c +c Check for slashes (new meter change syntax) +c + idxs = index(line(1),'/') + idxb = index(line(1),' ') + newmtr = idxs.gt.0 .and. (idxb.eq.0 .or. idxs.lt.idxb) + if (.not.newmtr) then +c +c Old way, no slashes, uses 'o' for lonesome '1' +c + icden = 3 + if (line(1)(2:2) .eq. 'o') then + mtrnum = 1 + else + mtrnum = ichar(line(1)(2:2))-48 + if (mtrnum .eq. 1) then + icden = 4 + mtrnum = 10+ichar(line(1)(3:3))-48 + end if + end if + mtrden = ichar(line(1)(icden:icden))-48 + else +c +c New way with slashes: idxs is index of 1st slash! +c + read(line(1)(2:idxs-1),'(i'//char(48+idxs-2)//')')mtrnum + idxb = index(line(1)(idxs+1:),'/') + read(line(1)(idxs+1:idxs+idxb-1), + * '(i'//char(48+idxb-1)//')')mtrden + end if + end if + lenbeat = ifnodur(mtrden,'x') + lenmult = 1 + if (mtrden .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnum*lenbeat + call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs) + end if + ip1 = 0 + line1 = line(1) + do 3 iw = 0 , nwbrs + if (iw .gt. 0) then + idx = ntindex(line1,wbrsym(iw)(1:lwbrs)) + if (idx .gt. 0) then +c +c Check for blank or shifted rest, discount it if it's there +c + if (line1(idx+lwbrs:idx+lwbrs).ne.' ') idx = 0 + end if + else + idx = ntindex(line1,'rp') +c +c Check for raised rest +c + if (idx.gt.0) then + if (line1(idx+2:idx+2).ne.' ') idx = 0 + end if + end if + if (idx .gt. 0) then + if (ip1 .eq. 0) then + ip1 = idx + else + ip1 = min(ip1,idx) + end if + end if +3 continue + if (i.lt.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq + * .or. ip1.eq.0) go to 2 +c +c Switch to multibar rest search mode!!! Start forward in line(1) +c + rpfirst = line1(ip1:ip1+1) .eq. 'rp' + iline = 1 + nmbr = 1 + if (rpfirst) then + lwbrsx = 2 + else + lwbrsx = lwbrs + end if + ipe = ip1+lwbrsx-1 +4 if (ipe .eq. len) then +c +c Need a new line +c + iline = iline+1 +6 read(10+iv,'(a)',end=998)line(iline) + len = lenstr(line(iline),128) + if (line(iline)(1:1).eq.'%' ) then + write(40,'(a)')'% Following comment has been moved forward' + write(40,'(a)')line(iline)(1:len) + go to 6 + end if + ipe = 0 + go to 4 +998 continue +c +c No more input left +c + print*,'All done!' + alldone = .true. + ipe = 0 + iline = iline-1 + len = lenstr(line(iline),128) + go to 4 + else + if (alldone) then + sym(1:1) = ' ' + else +c +c ipe=len ' + print*,'Send files to Dr. Don at dsimons@logicon.com' + stop + end if + do 1 ip = ipeold+1 , len + if (line(ip:ip) .ne. ' ') then +c +c symbol starts here (ip). We're committed to exit the loop. +c + if (ip .lt. len) then + do 2 iip = ip+1 , len + if (line(iip:iip) .ne. ' ') go to 2 +c +c iip is the space after the symbol +c + ipenew = iip-1 + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return +2 continue +c +c Have len>=2 and ends on len +c + ipenew = len + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return + else +c +c ip = len +c + ipenew = len + lsym = 1 + sym = line(ip:ip) + return + end if + end if +1 continue + print*,'Error #3. Send files to Dr. Don at dsimons@logicon.com' + end + function ntindex(line,s2q) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q + character*128 line,tline + logical intex +c +c print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' +c print*,line(1:79) +c +c +c Use a temporary string to store the input and test, so can zap D"..." +c + tline = line + ndxs2 = index(tline,s2q) +c +c Return point below for rechecks after zapping D" " +c +2 continue + ndxbs = index(tline,char(92)) + if (ndxbs .gt. 0) then +c +c Special check in case \ is inside D"..." +c + ndxDq1 = index(tline,'D"') +c +c If the following test fails, flow out of if block; else loop up to 2. +c + if (ndxDq1 .gt. 0) then +c +c Find end of D"..." +c + ndxDq2 = ndxDq1+1+index(tline(ndxDq1+2:128),'"') + if (ndxDq2 .eq. ndxDq1+1) then + print*,'Something is really wierd here' + stop + end if + tline = tline(1:ndxDq1-1) + do 3 ic = ndxDq1 , ndxDq2 + tline = tline(1:ic-1)//' ' +3 continue + tline = tline(1:ndxDq2)//line(ndxDq2+1:128) + go to 2 + end if + end if + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 +c print*,'No bs, or char is left of 1st bs, ntindex:',ntindex + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(tline,128) + intex = .true. +c print*,'intex+>',intex + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(tline(ic+1:len),s2q)+ic +c print*,'ndxs2 =>',ndxs2 + else + ntindex = ndxs2 + return + end if +c print*,'Internal exit, intex, ntindex:',intex,ntindex + else if (intex .and. tline(ic+1:ic+2).eq.char(92)//' ') then + intex = .false. +c print*,'intex+>',intex + else if (.not.intex .and. tline(ic+1:ic+2).eq.' '//char(92)) + * then + intex = .true. +c print*,'intex+>',intex + end if +1 continue +c print*,'Out end of loop 1' + end if +c print*,'Exiting ntindex at the end???' + return + end + subroutine getchar(line,iccount,charq) +c +c Gets the next character out of line*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount to position of the new character. +c + character*1 charq + character*128 line + if (iccount .eq. 128) then + read(10,'(a)')line + iccount = 0 + end if + iccount = iccount+1 + charq = line(iccount:iccount) + return + end + function readin(line,iccount,iread) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv +c +c Reads a piece of setup data from line, gets a new line from +c file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. +c +c iread controls copying of values into scratch files for parts, but only +c if not replacing. +c +c iread input value written +c -1 nvi nothing (only used when noinst<0 initially) +c 0 various value read +c 1 nv -1 , replace later with nvi(i) +c 2 noinst 1 +c 3 np -2 , replace later with (nsyst-1)/12+1 +c 4 musicsize 20 +c 5 fracondent 0.05 +c + character*128 line + character*1 durq +4 if (iccount .eq. 128) then + read(10,'(a)')line + if (replacing) replacing = .false. + call chkcom(line) + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')readin + if (.not.replacing) then + if (iread .eq. 0) then + call allparts(line(i1:i2),i2-i1+1) + else if (iread .eq. 1) then + call allparts('-999',4) + else if (iread .eq. 2) then + call allparts('1',1) + else if (iread .eq. 3) then + call allparts('-998',4) + else if (iread .eq. 4) then + call allparts('20',2) + else if (iread .eq. 5) then + call allparts('.05',3) + else if (iread .ne. -1) then + print*,'Error with iread in readin' + stop + end if + end if + return + end + subroutine chkcom(line) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,clefpend,botv + character*128 line +c +c Assume that line has just been read. No need to change iccount since we only +c process full lines. +c +1 if (line(1:1) .ne. '%') return +c +c If here, line has some sort of comment +c + if (line(2:2) .eq. '%') then + if (.not. insetup) then +c +c Suck up a line, then flow out of "if" block to get another and loop +c + read(10,'(a)')line + +c++VV +c +c UNLESS (a) it has a score-only "M" and changes # of inst's. +c + if (index(line,'M') .gt. 0) then + idxL = index(line,'L') + idxM = index(line,'M') + idxn = index(line,'n') + idxb = index(line,' ') + if (idxL.lt.idxM .and. idxM.lt.idxn .and. + * (idxb.eq.0 .or. idxn.lt.idxb)) then + noinow = ichar(line(idxn+1:idxn+1))-48 + clefpend = .true. +c +c Next noinow digits are original inst. #'s of new inst. set. Next noinow +c char's after that are clefs +c + nvnow = 0 + do 24 j = 1 , noinow + iorig(j) = ichar(line(idxn+1+j:idxn+1+j))-48 + iposc0 = idxn+1+noinow + do 25 k = 1 , nvi(iorig(j)) + nvnow = nvnow+1 +c clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) + instnum(nvnow) = j + botv(nvnow) = k.eq.1 .and. j.ne.1 +25 continue +24 continue + end if + end if +c +c or if it's "h" or "l", need to suck up one more line +c + if ((line(1:1).eq.'h'.and.index('+- ',line(2:2)).gt.0) .or. +c +c 4/29/00 check for T string also +c + * line(1:1).eq.'T' .or. + * line(1:2).eq.'l ') read(10,'(a)')line + else +c +c In setup mode. Set flag, flow out and do use following line +c + replacing = .true. + end if + else if (line(2:2) .eq. '!') then +c +c Copy to all parts +c + call allparts(line(3:128),125) + else +c +c Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise +cc Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise +c + ivq = index('123456789abcdefghijklmno',line(2:2)) +c +c Only treat as part-specific pmx line if number .le. noinst +c + if (ivq.lt.1 .or. ivq.gt.noinst) then +c +c Simple comment. +c + call allparts(line,128) + else +c +c Instrument comment, copy only to part +c + lenline = lenstr(line,128) + if (lenline .gt. 2) then + write(10+ivq,'(a)')line(3:lenline) + else +c +c Transferring blank line +c + write(10+ivq,'(a)')' ' + end if + end if + end if + read(10,'(a)',end=2)line + call zapbl(line,128) + go to 1 +2 continue + return + end + subroutine dosetup(iv,line,mtrnum,mtrden) + parameter (noimax=24) +c +c Transfers setup data from scratch file to real one for one instrument +c Data may be mixed with comments, but on entry 1st item is a number. +c Write a comment when encountered, as it comes. +c Write numbers one per line. +c Three input data require special handling: +c If not already replaced, i.e., if negative, then +c iset(1) (nv) will be replaced with nvi(i) +c iset(9) (npages) will be replaced with (nsyst-1)/12+1 +c iset(2), if negative, will be followed by extra numbers to be transf. +c + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,clefpend,botv + character*128 line + iccount = 0 + do 1 iset = 1 , 12 + call partnum(iv,iccount,line,xdata) + if (iset .eq. 2) then + if (xdata .gt. 0) then + write(40,'(i5)')int(xdata+.1) + else + noi = -xdata+.1 + write(40,'(i5)')noi + do 2 ioi = 1 , noi + call partnum(iv,iccount,line,xdata) + write(40,'(i5)')int(xdata+.1) +2 continue + end if +c else if (iset.ne.8 .and. xdata.lt.0) then + else if (iset.ne.8 .and. iset.ne.5 .and. xdata.lt.0) then +c +c Must be either nv or npages +c + if (int(-xdata+.1) .eq. 999) then +c +c It's nv +c + write(40,'(i5)')nvi(iv) + else +c +c npages must be computed +c + write(40,'(i5)')(nsyst-1)/12+1 + end if + else if (iset.ne.7 .and. iset.ne.12) then +c +c write integer +c + write(40,'(i5)')nint(xdata) + else +c +c write floating number +c + write(40,'(f5.2)')xdata + end if + if (iset .eq. 3) then + mtrnum = nint(xdata) + else if (iset .eq. 4) then + mtrden = nint(xdata) + end if +1 continue + return + end + subroutine partnum(iv,iccount,line,xdata) +c +c Simplified number parsing. Only looks for comment lines and numbers. +c + character*128 line + character*1 durq +2 if (iccount .eq. 128) then + read(10+iv,'(a)')line + if (line(1:1) .eq. '%') then + len = lenstr(line,128) + write(40,'(a)')line(1:len) + go to 2 + end if + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 4 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +4 continue +c +c If here, iccount=128 and need to get a new line +c + go to 2 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')xdata + return + end + block data + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + data nvi /noimax*1/, noinst,noinow /2*noimax/ + data botv /noimax*.false./ + end + subroutine zapbl(string,len) + character*(*) string + do 1 i = 1 , len + if (string(i:i) .eq. ' ')go to 1 + if (i .eq. 1) return + go to 2 +1 continue +c +c If line is all blank, leave it alone +c + return +2 continue + string = string(i:len) + return + end + subroutine OddQuotesBefore(lineq,indx,yesodd) +c +c This counts number of double quotes in lineq up to position indx-1, then +c sets yesodd according to whether number is odd or even +c + logical yesodd + character*(*) lineq + numdqs = 0 + do 1 i = 1 , indx-1 + if (lineq(i:i) .eq. '"') numdqs = numdqs+1 +1 continue + yesodd = mod(numdqs,2) .eq. 1 + return + end + + + + + diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig new file mode 100644 index 00000000000..b785cad009b --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig @@ -0,0 +1,1619 @@ +cccccccccccccccccccccccccc +cc +cc scor2prt 7/24/11 for PMX 2.615 +cccccccccccccccccccccccccc +c This program, developed by Don Simons (dsimons@roadrunner.com), is +c part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert +c with MusiXTeX and TeX, the purpose of PMX is to allow the user to create +c high-quality typeset musical scores by including a sequence of PMX commands +c in an ASCII input file. Scor2prt is an auxiliary program that creates PMX +c input files for individual parts from the PMX input file for the score. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see . +c +c +c 7/18/11 +c Start to fix up for AS..., also Ki was done a little earlier. +c 7/5/10 +c Modify Manual to explain extended hex numbering for part-specific comments +c 5/16/10 +c Extend part-specific comments for up to 24 parts (subroutine chkcom) +c Allow files 11-34 for parts +c Change file 30 to 40 +c 6/1/08 es2p +c noimax = 24 +c +c To do +c Override fracindent, musicsize? +c Deal with midbar R? +c 2/29/04 +c Check for special character being in quoted string. +c 10/20/02 PMX 2.407 +c Interpret AN[n]"[used-defined-part-file-name]" +c 1/21/02 +c Deals with rm in multiple parts. +c s2p15 +c Get right non-tex index even if there's "\" inside D"..." +c s2p14 +c 10/29/00 fix transfer to parts of negative mtrdnp +c 4/29/00 screen for "%%" followed by "T" +c Restore change from "Version 2.1a, 21 Dec" +c s2p13 +c Allow whole-bar double-whole rests. +c Bypass MIDI commands "I..." achar(10)="I" +c s2p12 +c Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla +c only taken as such if ? represents a hex digit .le. noinst, otherwise it's +c a simple comment. This lessens incompatibility. +c In subroutine mbrest, properly open parts 10-12 if needed +c s2p11 +c Ignore leading blanks +c Fix undefined linelength in mbrest at very end of comments. +c s2p10 +c Fix non-transfer of P..c" " +c Allow "%%" and "%"n anywhere +c Version 1.43 +c Fix bug with P in TeX string. +c Ignore shifted whole-bar rests when consolidating whole-bar rests +c Copy type 4 TeX into all parts. +c Deal with XB and XP. +c Permit transfer of blank line into parts +c Change staves/inst in 'M' command. +c Arbitrary staves/inst. +c Recognize m1/2/3/4 syntax. +c Enable comment and one-voice syntax in instrument names +c +c Changes since 1.1 +c Deal with saved macros. +c Revise setup readin, to admit comments. +c Do not copy 'X' into parts +c +cccccccccccccccccccccccccccccccccccccccccccccccc + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + integer*4 ludpfn(noimax) + character*1 sq,achar(10) + character*2 termsym + character*27 jobname,infileq + character*128 instrum(noimax),udpfnq(noimax) + character*128 line,holdln,templine + logical termrpt,isachar,frstln,oneof2,botv,clefpend,fexist, + * insetup,replacing,gotname,yesodd + data achar /'P','m','V','R','A','h','w','K','M','I'/ + clefpend = .false. + insetup = .true. + replacing = .false. + frstln = .true. + lenhold = 0 + sq = char(92) + print*,'This is scor2prt for PMX 2.615, 24 July 2011' + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else + call getarg(1,jobname,idum) ! May need to replace this w/ next line +c call getarg(1,jobname) + end if + ljob = lenstr(jobname,27) + if (ljob .eq. 0) then + print*,'No was jobname entered. Restart and try again.' + stop + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + stop + end if + open(10,file=jobname(1:ljob)//'.pmx') +c +c Open all instrument files now for allparts stuff. Later disgard those >nv +c + do 19 iv = 1 , noimax + iorig(iv) = iv + open(10+iv,status='SCRATCH') + ludpfn(iv) = 0 +19 continue + read(10,'(a)')line + call chkcom(line) + if (line(1:3) .eq. '---') then + call allparts(line,128) +31 read(10,'(a)')line + if (line(1:3) .ne. '---') then + call allparts(line,128) + go to 31 + end if + call allparts(line,128) + read(10,'(a)')line + call chkcom(line) + end if + iccount = 0 + nv = readin(line,iccount,1)+.1 + noinst = readin(line,iccount,2)+.1 + if (noinst .gt. 0) then + nvi(1) = nv-noinst+1 + else + noinst = 1-noinst + do 21 iinst = 1 , noinst + nvi(iinst) = readin(line,iccount,-1)+.1 +21 continue + end if + noinow = noinst + insnow = 1 +c +c ivlast is last iv in current inst. instnum(iv) is iinst for current voice. +c + ivlast = nvi(1) + do 22 iv = 1 , nv + instnum(iv) = insnow + if (iv .eq. ivlast) then + if (iv .lt. nv) botv(iv+1) = .true. +c +c The previous stmt will set botv true only for bot voice of iinst>1. It is +c used when writing termrpts, but the one in voice one is handled differently, +c so botv(1) is left .false. +c + if (insnow .lt. noinst) then + insnow = insnow+1 + ivlast = ivlast+nvi(insnow) + end if + end if +22 continue + mtrnuml = readin(line,iccount,0)+.1 + mtrdenl = readin(line,iccount,0)+.1 + mtrnmp = readin(line,iccount,0)+.1 + mtrdnp = readin(line,iccount,0)+.1 + xmtrnum0 = readin(line,iccount,0) + isig = readin(line,iccount,0)+.1 + npages = readin(line,iccount,3)+.1 + nsyst = readin(line,iccount,0)+.1 + musicsize = readin(line,iccount,4)+.1 + fracindent = readin(line,iccount,5) + if (npages .eq. 0) then + print*, + *'You entered npages=0, which means nsyst is not the total number' + print*, + *'of systems. Scor2prt has to know the total number of systems.' + print*, + *'Please set npages and nsyst to their real values.' + stop + end if +c +c Must leave insetup=.true. else could bypass ALL instrument names. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) +c +c Normally this puts pointer at start of line with 1st inst name +c Check if prior line was "%%" +c + backspace(10) + read(10,'(a)')line + if (line(1:2) .eq. '%%') backspace(10) + do 14 iv = 1 , noinst + gotname = .false. +16 read(10,'(a)') instrum(iv) + if (instrum(iv)(1:2) .eq. '%%') then + read(10,'(a)')line + go to 16 + else if (instrum(iv)(1:1) .eq. '%') then + ivq = ichar(instrum(iv)(2:2))-48 + if (ivq.ne.iv) then +c +c It's really a comment. Copy to parts, then get another trial name. +c + call allparts(instrum(iv),128) + go to 16 + else + line = instrum(iv)(3:) + instrum(iv) = line + gotname = .true. + end if + else + gotname = .true. + end if +cc +cc The following checks for macro that write original C-clef as part of +cc instrument name. See pmx.tex +cc +c if (index(instrum(iv),'namewpc') .eq. 0) then +c write(10+iv,'(a)')' ' +c else +c inm1 = index(instrum(iv),'{')+1 +c inm2 = index(instrum(iv),'}')-1 +c read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 +c write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// +c * char(iy1+49)//char(iy2+49) +c instrum(iv) = instrum(iv)(inm1:inm2) +c end if + if (.not.gotname) then + print*,'You must provide a replacement instrument name' + stop + end if + write(10+iv,'(a)')' ' +14 continue + replacing = .false. + nvnow = nv +c +c Clef string: Note insetup is still T, so "%%" will be treated specially +c + read(10,'(a)')line + call chkcom(line) + if (replacing) then +c +c If here, we have next line after "%%", containing score's clef string +c Assume all clefs are handled with instrument comments. +c + read(10,'(a)')line + call chkcom(line) + backspace(10) + else +c +c If here, line has the clef string in it. Handle the old way +c + kvstart = 1 + kvend = nvi(1) + do 2 inst = 1 , noinst + write(10+inst,'(a'//char(48+nvi(inst))//')') + * line(kvstart:kvend) + if (inst .lt. noinst) then + kvstart = kvend+1 + kvend = kvstart+nvi(inst+1)-1 + end if +2 continue + end if + replacing = .false. + insetup = .false. +c +c *****NOTE*****This comment applies to stuff done earlier! +c Before starting the big loop, copy initial instnum and staffnum stuff +c into working values. Latter may change if noinst changes. Also make +c list of current inst nums relative to original ones. In addition to those +c below, must redo instnum(iv) and botv(iv) when we change noinst. +c +c Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! +c +18 read(10,'(a)') line + if (line(1:1) .eq. '%') then + call allparts(line,128) + go to 18 + end if + call allparts(line,128) +c +c Write instrument names. Will be blank if later part of a score. +c + if (instrum(1)(1:1) .ne. ' ') then + do 3 iv = 1 , noinst + len = lenstr(instrum(iv),79) + write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len) +3 continue + end if +c +c The big loop. Except for '%%', put all comment lines in all parts. +c Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts +c If a line starts with %!, put the rest of it in each part. +c If a line starts with %[n], put the rest of it in part [n]. +c Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. +c Assume they only come at top of block, except terminal repeat needs +c special handling. +c Check for "P"; ignore in parts. +c Check for consecutive full-bar rests; if found, replace with rm[nn] +c + iv = 1 + iinst = 1 + termrpt = .false. +4 read(10,'(a)',end=999)line + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + call zapbl(line,128) + call chkcom(line) + lenline = lenstr(line,128) + if (lenline .eq. 0) go to 4 + if (line(1:1) .eq. 'T') then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (line(1:2) .eq. sq//sq) then + call allparts(line,128) + go to 4 + else if (index('hl',line(1:1)).gt.0 .and. + * index(' +-',line(2:2)) .gt. 0) then + call allparts(line,128) + read(10,'(a)')line + call allparts(line,128) + go to 4 + else if (iv .eq. 1) then + do 5 ia = 1 , 10 +24 continue + idxa = ntindex(line,achar(ia)) + isachar = idxa .gt. 0 + if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' ' +c +c 1 2 3 4 5 6 7 8 9 10 +c data achar /'P','m','V','R','A','h','w','K','M','I'/ +c + if (ia .eq. 9) isachar = + * isachar .and. line(idxa+1:idxa+1).eq.'S' + if (isachar) then +c +c Check whether character is inside a quoted string by counting +c how many quotes precede it in the line +c + + call OddQuotesBefore(line,idxa,yesodd) + if (yesodd) isachar=.false. + end if + if (isachar) then +c +c Find next blank +c + do 6 ib = idxa+1 , 128 + if (line(ib:ib) .eq. ' ') go to 7 +6 continue + print*,'Problem with "V,R,m,P,A,h,MS, or w"' + print*, + * 'Send files to Dr. Don at dsimons at roadrunner dot com' + stop 1 +7 continue +c +c Next blank is at position ib. Later, if ia=1, must check for Pc" " ; +c i.e., look for '"' between P and blank +c + if (ia .eq. 4) then +c +c Check for terminal repeat. Note if there's a term rpt, there can't be any +c others. Also, must process repeats LAST, after m's and 'V's +c + do 8 ic = ib+1 , 128 +c +c If any subsequent character on this line is neither blank nor "/", get out +c + if (index(' /',line(ic:ic)) .eq. 0) go to 9 + if (line(ic:ic) .eq. '/') then + termrpt = .true. + termsym = line(ib-2:ib-1) +c +c Process the line as if there were no "R" +c + go to 10 + end if +8 continue +c +c +++ 060812 +c If here, all chars after "R" symbol are blanks, so process the line normally, +c but only IF next line is not the M-Tx line " /" +c + read(10,'(a)')templine + if (templine(1:2) .ne. ' /') then + backspace(10) ! and flow out + else +c +c We have the M-Tx case where one line ends with R? and next is " /". Add / to the line, +c and proceed as above +c + line = line(1:ib)//'/' + lenline = lenline+2 + termrpt = .true. + termsym = line(ib-2:ib-1) + go to 10 + end if +c +++ 060812 +c + else if (ia .eq. 1) then + idxq = ntindex(line,'"') + if (idxq.gt.idxa .and. idxq.lt.ib) then +c +c Quote is between P and next blank. Find 2nd quote, starting at the blank. +c + idxq2 = ib-1+ntindex(line,'"') + if (idxq.eq.0 .or. line(idxq2+1:idxq2+1).ne.' ') then + print* + print*,'Error copying P with quotes, idxq2:',idxq2 + print*,line(1:60) + stop 1 + end if + ib = idxq2+1 + end if +c +c Do not transfer P into parts. +c + go to 12 + else if (ia .eq. 9) then +c +c Start Saving a macro. After leaving here, a symbol will be sent to all parts, +c If all on this line, set ib to end and exit normally. +c + ndxm = index(line(ib+1:128),'M') + if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then +c +c Macro ends on this line +c + ib = ib+ndxm+1 + else +c +c Save leading part of current line +c + lenhold = idxa-1 + if (lenhold .gt. 0) holdln = line(1:lenhold) +c +c Transfer rest of line +c + call allparts(line(idxa:128),129-idxa) +c +c Read next line +c +20 read(10,'(a)')line +c +c Check for comment, transfer and loop if so +c +c if (line(1:1) .eq.'%') then +23 if (line(1:1) .eq.'%') then +c call allparts(line,128) +c go to 20 + call chkcom(line) + go to 23 + end if +c +c Look for terminal ' M' +c + if (line(1:1) .eq. 'M') then + ndxm = 1 + else + ndxm = index(line,' M') + if (ndxm .gt. 0) ndxm = ndxm+1 + end if + if (ndxm .gt. 0) then +c +c Set parameters, exit normally (but later check for leading part of 1st line +c + idxa = 1 + ib = ndxm+1 + else +c +c No "M", transfer entire line, loop +c + call allparts(line,128) + go to 20 + end if + end if + else if (ia .eq. 10) then +c +c Do not transfer MIDI command into parts +c + go to 12 + else if (ia .eq. 5) then +c +c First check for "AS", but S may come after other "A" options +c + idxS = index(line(idxa+1:ib),'S') + if (idxS .gt. 0) then +c +c Get rid of the string. First check if that's all there is in A. +c + if (ib-idxa .eq. nv+2) go to 12 + line = line(1:idxa+idxS-1)//line(idxa+idxS+nv+1:ib) + end if +c +c Check for user-defined part file name. Must start in column 1 and have +c AN[n]"userfilename". +c idxa is position of "A" +c ib is position of the next blank after "A" +c Don't allow any blanks in user +c + if (line(idxa+1:idxa+1) .ne. 'N') go to 9 ! bail out + if (idxa .ne. 1) then + print* + print*, + * 'You entered "AN..." somewhere beyond first column; stopping.' + stop 1 + end if +c +c pmxa already checked for valid one- or 2-digit number, so get it +c + if (line(4:4) .eq. '"') then +c +c Single digit instrument number +c + read(line(3:3),'(i1)')iudpfn + idxstartname = 5 + else + read(line(3:4),'(i2)')iudpfn + idxstartname = 6 + end if + ludpfn(iudpfn) = index(line(idxstartname:128),'"')-1 + if (ludpfn(iudpfn) .lt. 0) then + print* + print*,'User-defined part file name must be in quotes' + stop 1 + end if + idxendname = idxstartname+ludpfn(iudpfn)-1 + udpfnq(iudpfn) = line(idxstartname:idxendname) +c +c Get a new line! +c + go to 4 + else if (ia .eq. 8) then +c +c Key change/transposition. +c If not instrument specific, copy to all parts +c + if (line(idxa+1:idxa+1).ne.'i') go to 9 +c +c Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]... +c + ibb = idxa+2 ! Starts on digit after 'i' +40 continue + read(line(ibb:ibb),'(i1)')iiinst ! 1st digit of iinst + itemp = (index('01234567890',line(ibb+1:ibb+1))) + if (itemp.gt.0) then + ibb = ibb+1 + iiinst = 10*iiinst+itemp-1 + end if + ibb = ibb+1 ! now at first +/-. Need end of 2nd number + itemp = index(line(ibb+1:ib),'i') ! Rel pos'n of next 'i' or 0 + if (itemp .gt. 0) then + iend = ibb+itemp-1 + else + iend = ib-1 + end if + write(10+iorig(iiinst),'(a)')'Ki1'//line(ibb:iend) + if (itemp .gt. 0) then + ibb = iend+2 + go to 40 + end if + go to 12 ! Remove K command from string, go to next ia + end if +9 continue + call allparts(line(idxa:ib-1),ib-idxa) +12 continue +c +c Remove the string from line +c + if (idxa .eq. 1) then + line = line(ib:128) + else + line = line(1:idxa-1)//line(ib:128) + end if + lenline = lenstr(line,128) +c +c Loop if only blanks are left +c + if (lenline .eq. 0) go to 4 +c +c Must check for multiple "I" commands, so go to just after start of ia loop +c + if (ia .eq. 10) go to 24 +c +c Tack on front part from 1st line of saved macro +c + if (lenhold .gt. 0) then + line = holdln(1:lenhold)//' '//line(1:lenline) + lenhold = 0 + end if + end if +5 continue + end if +c +c Now a special loop to deal with 'X'. If it was %[n]X..., will have been +c copied into part [n] already. If no "B" or "P", remove. If "P", just +c remove the "P" so pmxa/b will process. If "B". do nothing. +c +10 continue + nchk = 1 +13 ntinx = nchk-1+ntindex(line(nchk:),'X') + if (ntinx .gt. nchk-1) then +c +c There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. +c + if (ntinx.gt.1) then + if (line(ntinx-1:ntinx-1).ne.' ') then +c +c The X is not 1st char of PMX command. Advance starting point, loop. +c + nchk = ntinx+1 + go to 13 + end if + end if +c +c We now know the X at ntinx starts a PMX command. Find next blank +c + ib = ntinx+index(line(ntinx+1:),' ') +c +c There must be a blank to right of "X", so ib>ntinx +c +c locp = nchk-1+index(line(nchk:ib),'P') + locp = ntinx+index(line(ntinx+1:ib),'P') +c +c Did not need to use ntindex because we already know bounds of PMX command. +c +c if (locp .gt. nchk-1) then + if (locp .gt. ntinx) then +c +c Strip out the 'P' +c + templine = line(1:locp-1) + line = templine(1:locp-1)//line(locp+1:lenline) + lenline = lenline-1 + ib = ib-1 + end if + if (index(line(ntinx:ib),':').gt.0 .or. + * index(line(ntinx:ib),'S').gt.0 .or. + * index(line(ntinx:ib),'B').gt.0 .or. locp.gt.ntinx) then +c +c The X command is a shift, "Both", or "Part". Do not remove. +c + nchk = ib+1 + go to 13 + end if +c +c Remove the X command. +c + if (ntinx .eq. 1) then + if (ib .lt. lenline) then + line = line(ib+1:lenline) + else +c +c line contains ONLY the "X" command, so get a new line +c + go to 4 + end if + else + templine = line(1:ntinx-1) + if (ib .lt. lenline) then + line = templine(1:ntinx-1)//line(ib+1:lenline) + else + line = templine(1:ntinx-1) + end if + end if +c +c Recompute lenline +c + lenline = lenstr(line,128) +c +c Resume checking after location of removed command. +c + nchk = ntinx + go to 13 + end if +c +c End of loop for X-checks +c + oneof2 = ntindex(line,'//') .gt. 0 + if (termrpt .and. botv(iv) .and. frstln .and. + * line(lenline:lenline).eq.'/') then +c +c Must add a terminal repeat before the slash +c + if (oneof2) lenline = lenline-1 + if (lenline.gt.1) write(10+iorig(iinst),'(a)')line(1:lenline-1) + if (.not. oneof2) then + line = termsym//' /' + lenline = 4 + else + line = termsym//' //' + lenline = 5 + end if + end if + if (termrpt .and. frstln .and. line(lenline:lenline).eq.'/' .and. + * iv.eq.nvnow) termrpt = .false. + write(10+iorig(iinst),'(a)')line(1:lenline) + if (oneof2) then + frstln = .false. + else if (.not.frstln) then + frstln = .true. + end if +c if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then + if (ntindex(line,'/').gt.0 .and. ntindex(line,'//').eq.0) then + iv = 1+mod(iv,nvnow) + iinst = instnum(iv) + end if + go to 4 +999 continue + close(10) +c +c In the mbrest checks, must run through ALL noinst files (not just noinow) +c + do 11 iinst = 1 , noinst +ccc+++ +cc +cc Temporarily transfer entire scratch file to real file +cc +c rewind(10+iinst) +c open(40,file='s2pout'//char(48+iinst)//'.pmx') +c do 50 m = 1 , 10000 +c read(10+iinst,'(a)',end=51)line +c lenline = lenstr(line,128) +c if (lenline .ge. 1) then +c write(40,'(a)')line(1:lenline) +c else +c write(40,'(a)')' ' +c end if +c50 continue +c51 continue +c close(40) +ccc+++ + if (nvi(iinst) .eq. 1) then + call mbrests(iinst,jobname,ljob,ludpfn(iinst),udpfnq(iinst)) + else +c +c Send a signal with ljob to bypass most mbrest processing +c + call mbrests(iinst,jobname,-ljob,ludpfn(iinst),udpfnq(iinst)) + end if +11 continue + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + subroutine allparts(string,n) + parameter (noimax=24) + character*(*) string + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + len = lenstr(string,n) + if (len .eq. 0) then + len = 1 + string = ' ' + end if + do 1 iinst = 1 , noinow + write(10+iorig(iinst),'(a)')string(1:len) +1 continue + return + end + subroutine mbrests(iv,jobname,ljob,ludpfn,udpfnq) + character*128 line(50),line1,udpfnq + character*80 sym + character*12 jobname + character*3 wbrsym(2) + character*2 partq + character*1 sq + logical wbrest,alldone,rpfirst,newmtr,type4 + type4 = .false. + sq = char(92) + alldone = .false. + rewind(10+iv) +c open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') + if (iv .lt. 10) then + partq(1:1) = char(48+iv) + lpart = 1 +c +c 5/16/10 Fix for >20 parts +c +c else +c partq = '1'//char(38+iv) +c lpart = 2 + else + lpart = 2 + if (iv .lt. 20) then + partq = '1'//char(38+iv) + else + partq = '2'//char(28+iv) + end if + end if +c if (ludpfn .eq. 0) then + open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx') +c else +c open(30,file=udpfnq(1:ludpfn)//'.pmx') +c end if + do 10 i = 1 , 10000 + read(10+iv,'(a)')line(1) + if (line(1)(1:1).eq.'%' .or. line(1)(1:3).eq.'---' + * .or. type4) then + len = lenstr(line(1),128) + if (len .gt. 0) then + write(40,'(a)')line(1)(1:len) + else + write(40,'(a)')' ' + end if + if (line(1)(1:3).eq.'---') type4 = .not.type4 + else + go to 11 + end if +10 continue + print*,'You should not be here in scor2prt. Call Dr. Don' + stop +11 continue +c +c Finished reading opening type4 TeX and comments. Next line to be read +c will contain the first of the input numbers +c + call dosetup(iv,line(1),mtrnum,mtrden) + do 1 i = 1 , 10000 +13 read(10+iv,'(a)',end=999)line(1) +7 len = lenstr(line(1),128) +c +c Pass-through if instrumnet has >1 voice. +c + if (ljob .lt. 0) go to 2 + if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then +c +c Traps titles, instruments, composers, headers, lower strings. Read 2 lines. +c + write(40,'(a)')line(1)(1:len) + read(10+iv,'(a)')line(1) + len = lenstr(line(1),128) + go to 2 + end if + if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then +c +c NOTE! The above test is truly bogus. +c + if (line(1)(1:1) .eq. '%') then + write(40,'(a)')line(1)(1:len) + go to 13 + end if + if (i .eq. 1) then +c read(line(1),'(10x,2i5)')mtrnum,mtrden + else +c +c Check for slashes (new meter change syntax) +c + idxs = index(line(1),'/') + idxb = index(line(1),' ') + newmtr = idxs.gt.0 .and. (idxb.eq.0 .or. idxs.lt.idxb) + if (.not.newmtr) then +c +c Old way, no slashes, uses 'o' for lonesome '1' +c + icden = 3 + if (line(1)(2:2) .eq. 'o') then + mtrnum = 1 + else + mtrnum = ichar(line(1)(2:2))-48 + if (mtrnum .eq. 1) then + icden = 4 + mtrnum = 10+ichar(line(1)(3:3))-48 + end if + end if + mtrden = ichar(line(1)(icden:icden))-48 + else +c +c New way with slashes: idxs is index of 1st slash! +c + read(line(1)(2:idxs-1),'(i'//char(48+idxs-2)//')')mtrnum + idxb = index(line(1)(idxs+1:),'/') + read(line(1)(idxs+1:idxs+idxb-1), + * '(i'//char(48+idxb-1)//')')mtrden + end if + end if + lenbeat = ifnodur(mtrden,'x') + lenmult = 1 + if (mtrden .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnum*lenbeat + call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs) + end if + ip1 = 0 + line1 = line(1) + do 3 iw = 0 , nwbrs + if (iw .gt. 0) then + idx = ntindex(line1,wbrsym(iw)(1:lwbrs)) + if (idx .gt. 0) then +c +c Check for blank or shifted rest, discount it if it's there +c + if (line1(idx+lwbrs:idx+lwbrs).ne.' ') idx = 0 + end if + else + idx = ntindex(line1,'rp') +c +c Check for raised rest +c + if (idx.gt.0) then + if (line1(idx+2:idx+2).ne.' ') idx = 0 + end if + end if + if (idx .gt. 0) then + if (ip1 .eq. 0) then + ip1 = idx + else + ip1 = min(ip1,idx) + end if + end if +3 continue + if (i.lt.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq + * .or. ip1.eq.0) go to 2 +c +c Switch to multibar rest search mode!!! Start forward in line(1) +c + rpfirst = line1(ip1:ip1+1) .eq. 'rp' + iline = 1 + nmbr = 1 + if (rpfirst) then + lwbrsx = 2 + else + lwbrsx = lwbrs + end if + ipe = ip1+lwbrsx-1 +4 if (ipe .eq. len) then +c +c Need a new line +c + iline = iline+1 +6 read(10+iv,'(a)',end=998)line(iline) + len = lenstr(line(iline),128) + if (line(iline)(1:1).eq.'%' ) then + write(40,'(a)')'% Following comment has been moved forward' + write(40,'(a)')line(iline)(1:len) + go to 6 + end if + ipe = 0 + go to 4 +998 continue +c +c No more input left +c + print*,'All done!' + alldone = .true. + ipe = 0 + iline = iline-1 + len = lenstr(line(iline),128) + go to 4 + else + if (alldone) then + sym(1:1) = ' ' + else +c +c ipe=len ' + print*,'Send files to Dr. Don at dsimons@logicon.com' + stop + end if + do 1 ip = ipeold+1 , len + if (line(ip:ip) .ne. ' ') then +c +c symbol starts here (ip). We're committed to exit the loop. +c + if (ip .lt. len) then + do 2 iip = ip+1 , len + if (line(iip:iip) .ne. ' ') go to 2 +c +c iip is the space after the symbol +c + ipenew = iip-1 + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return +2 continue +c +c Have len>=2 and ends on len +c + ipenew = len + lsym = ipenew-ip+1 + sym = line(ip:ipenew) + return + else +c +c ip = len +c + ipenew = len + lsym = 1 + sym = line(ip:ip) + return + end if + end if +1 continue + print*,'Error #3. Send files to Dr. Don at dsimons@logicon.com' + end + function ntindex(line,s2q) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q + character*128 line,tline + logical intex +c +c print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' +c print*,line(1:79) +c +c +c Use a temporary string to store the input and test, so can zap D"..." +c + tline = line + ndxs2 = index(tline,s2q) +c +c Return point below for rechecks after zapping D" " +c +2 continue + ndxbs = index(tline,char(92)) + if (ndxbs .gt. 0) then +c +c Special check in case \ is inside D"..." +c + ndxDq1 = index(tline,'D"') +c +c If the following test fails, flow out of if block; else loop up to 2. +c + if (ndxDq1 .gt. 0) then +c +c Find end of D"..." +c + ndxDq2 = ndxDq1+1+index(tline(ndxDq1+2:128),'"') + if (ndxDq2 .eq. ndxDq1+1) then + print*,'Something is really wierd here' + stop + end if + tline = tline(1:ndxDq1-1) + do 3 ic = ndxDq1 , ndxDq2 + tline = tline(1:ic-1)//' ' +3 continue + tline = tline(1:ndxDq2)//line(ndxDq2+1:128) + go to 2 + end if + end if + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 +c print*,'No bs, or char is left of 1st bs, ntindex:',ntindex + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(tline,128) + intex = .true. +c print*,'intex+>',intex + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(tline(ic+1:len),s2q)+ic +c print*,'ndxs2 =>',ndxs2 + else + ntindex = ndxs2 + return + end if +c print*,'Internal exit, intex, ntindex:',intex,ntindex + else if (intex .and. tline(ic+1:ic+2).eq.char(92)//' ') then + intex = .false. +c print*,'intex+>',intex + else if (.not.intex .and. tline(ic+1:ic+2).eq.' '//char(92)) + * then + intex = .true. +c print*,'intex+>',intex + end if +1 continue +c print*,'Out end of loop 1' + end if +c print*,'Exiting ntindex at the end???' + return + end + subroutine getchar(line,iccount,charq) +c +c Gets the next character out of line*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount to position of the new character. +c + character*1 charq + character*128 line + if (iccount .eq. 128) then + read(10,'(a)')line + iccount = 0 + end if + iccount = iccount+1 + charq = line(iccount:iccount) + return + end + function readin(line,iccount,iread) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv +c +c Reads a piece of setup data from line, gets a new line from +c file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. +c +c iread controls copying of values into scratch files for parts, but only +c if not replacing. +c +c iread input value written +c -1 nvi nothing (only used when noinst<0 initially) +c 0 various value read +c 1 nv -1 , replace later with nvi(i) +c 2 noinst 1 +c 3 np -2 , replace later with (nsyst-1)/12+1 +c 4 musicsize 20 +c 5 fracondent 0.05 +c + character*128 line + character*1 durq +4 if (iccount .eq. 128) then + read(10,'(a)')line + if (replacing) replacing = .false. + call chkcom(line) + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')readin + if (.not.replacing) then + if (iread .eq. 0) then + call allparts(line(i1:i2),i2-i1+1) + else if (iread .eq. 1) then + call allparts('-999',4) + else if (iread .eq. 2) then + call allparts('1',1) + else if (iread .eq. 3) then + call allparts('-998',4) + else if (iread .eq. 4) then + call allparts('20',2) + else if (iread .eq. 5) then + call allparts('.05',3) + else if (iread .ne. -1) then + print*,'Error with iread in readin' + stop + end if + end if + return + end + subroutine chkcom(line) + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,clefpend,botv + character*128 line +c +c Assume that line has just been read. No need to change iccount since we only +c process full lines. +c +1 if (line(1:1) .ne. '%') return +c +c If here, line has some sort of comment +c + if (line(2:2) .eq. '%') then + if (.not. insetup) then +c +c Suck up a line, then flow out of "if" block to get another and loop +c + read(10,'(a)')line + +c++VV +c +c UNLESS (a) it has a score-only "M" and changes # of inst's. +c + if (index(line,'M') .gt. 0) then + idxL = index(line,'L') + idxM = index(line,'M') + idxn = index(line,'n') + idxb = index(line,' ') + if (idxL.lt.idxM .and. idxM.lt.idxn .and. + * (idxb.eq.0 .or. idxn.lt.idxb)) then + noinow = ichar(line(idxn+1:idxn+1))-48 + clefpend = .true. +c +c Next noinow digits are original inst. #'s of new inst. set. Next noinow +c char's after that are clefs +c + nvnow = 0 + do 24 j = 1 , noinow + iorig(j) = ichar(line(idxn+1+j:idxn+1+j))-48 + iposc0 = idxn+1+noinow + do 25 k = 1 , nvi(iorig(j)) + nvnow = nvnow+1 +c clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) + instnum(nvnow) = j + botv(nvnow) = k.eq.1 .and. j.ne.1 +25 continue +24 continue + end if + end if +c +c or if it's "h" or "l", need to suck up one more line +c + if ((line(1:1).eq.'h'.and.index('+- ',line(2:2)).gt.0) .or. +c +c 4/29/00 check for T string also +c + * line(1:1).eq.'T' .or. + * line(1:2).eq.'l ') read(10,'(a)')line + else +c +c In setup mode. Set flag, flow out and do use following line +c + replacing = .true. + end if + else if (line(2:2) .eq. '!') then +c +c Copy to all parts +c + call allparts(line(3:128),125) + else +c +c Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise +cc Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise +c + ivq = index('123456789abcdefghijklmno',line(2:2)) +c +c Only treat as part-specific pmx line if number .le. noinst +c + if (ivq.lt.1 .or. ivq.gt.noinst) then +c +c Simple comment. +c + call allparts(line,128) + else +c +c Instrument comment, copy only to part +c + lenline = lenstr(line,128) + if (lenline .gt. 2) then + write(10+ivq,'(a)')line(3:lenline) + else +c +c Transferring blank line +c + write(10+ivq,'(a)')' ' + end if + end if + end if + read(10,'(a)',end=2)line + call zapbl(line,128) + go to 1 +2 continue + return + end + subroutine dosetup(iv,line,mtrnum,mtrden) + parameter (noimax=24) +c +c Transfers setup data from scratch file to real one for one instrument +c Data may be mixed with comments, but on entry 1st item is a number. +c Write a comment when encountered, as it comes. +c Write numbers one per line. +c Three input data require special handling: +c If not already replaced, i.e., if negative, then +c iset(1) (nv) will be replaced with nvi(i) +c iset(9) (npages) will be replaced with (nsyst-1)/12+1 +c iset(2), if negative, will be followed by extra numbers to be transf. +c + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + character*128 line + iccount = 0 + do 1 iset = 1 , 12 + call partnum(iv,iccount,line,xdata) + if (iset .eq. 2) then + if (xdata .gt. 0) then + write(40,'(i5)')int(xdata+.1) + else + noi = -xdata+.1 + write(40,'(i5)')noi + do 2 ioi = 1 , noi + call partnum(iv,iccount,line,xdata) + write(40,'(i5)')int(xdata+.1) +2 continue + end if +c else if (iset.ne.8 .and. xdata.lt.0) then + else if (iset.ne.8 .and. iset.ne.5 .and. xdata.lt.0) then +c +c Must be either nv or npages +c + if (int(-xdata+.1) .eq. 999) then +c +c It's nv +c + write(40,'(i5)')nvi(iv) + else +c +c npages must be computed +c + write(40,'(i5)')(nsyst-1)/12+1 + end if + else if (iset.ne.7 .and. iset.ne.12) then +c +c write integer +c + write(40,'(i5)')nint(xdata) + else +c +c write floating number +c + write(40,'(f5.2)')xdata + end if + if (iset .eq. 3) then + mtrnum = nint(xdata) + else if (iset .eq. 4) then + mtrden = nint(xdata) + end if +1 continue + return + end + subroutine partnum(iv,iccount,line,xdata) +c +c Simplified number parsing. Only looks for comment lines and numbers. +c + character*128 line + character*1 durq +2 if (iccount .eq. 128) then + read(10+iv,'(a)')line + if (line(1:1) .eq. '%') then + len = lenstr(line,128) + write(40,'(a)')line(1:len) + go to 2 + end if + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 4 iccount = iccount , 127 + if (line(iccount:iccount) .ne. ' ') go to 3 +4 continue +c +c If here, iccount=128 and need to get a new line +c + go to 2 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(line,iccount,durq) +c +c Remember that getchar first increments iccount, *then* reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + stop 1 + end if + icf = i2-i1+49 + read(line(i1:i2),'(f'//char(icf)//'.0)')xdata + return + end + block data + parameter (noimax=24) + common /all/ noinow,iorig(noimax),noinst,insetup,replacing, + * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow + logical insetup,replacing,botv + data nvi /noimax*1/, noinst,noinow /2*noimax/ + data botv /noimax*.false./ + end + subroutine zapbl(string,len) + character*(*) string + do 1 i = 1 , len + if (string(i:i) .eq. ' ')go to 1 + if (i .eq. 1) return + go to 2 +1 continue +c +c If line is all blank, leave it alone +c + return +2 continue + string = string(i:len) + return + end + subroutine OddQuotesBefore(lineq,indx,yesodd) +c +c This counts number of double quotes in lineq up to position indx-1, then +c sets yesodd according to whether number is odd or even +c + logical yesodd + character*(*) lineq + numdqs = 0 + do 1 i = 1 , indx-1 + if (lineq(i:i) .eq. '"') numdqs = numdqs+1 +1 continue + yesodd = mod(numdqs,2) .eq. 1 + return + end + + + + + diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid new file mode 100644 index 00000000000..ccd7219e2be Binary files /dev/null and b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid differ diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml new file mode 100644 index 00000000000..0c514716522 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml @@ -0,0 +1,24 @@ +This is PMX, Version 2618 , 19 Mar 12 +Opening barsant.pmx + Starting first PMX pass + + Bar 1 Bar 2 Bar 3 Bar 4 Bar 5 Bar 6 Bar 7 Bar 8 Bar 9 Bar 10 Bar 11 + Bar 12 Bar 13 Bar 14 Bar 15 Bar 16 Bar 17 + Done with first pass + + nlbuf: 50 +Starting second PMX pass + +WARNING + In a title block, you have specified instrument and/or + composer but no title for the piece. + + Bar 1 Bar 2 Bar 3 Bar 4 Bar 5 Bar 6 Bar 7 Bar 8 Bar 9 Bar 10 Bar 11 + Bar 12 Bar 13 Bar 14 Bar 15 Bar 16 Bar 17 +Writing ./barsant.tex + Done with second PMX pass. Now run TeX + +Writing barsant.mid +MIDI instrument 0 is 74 +MIDI instrument 1 is 6 + Bytes used: 2126 807 21 diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx new file mode 100644 index 00000000000..f10fd67b064 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx @@ -0,0 +1,68 @@ +%----------------% +% +% barsant.pmx Revised 29 June 2002 +% +%----------------% +% +% nv,noinst,mtrnuml,mtrdenl,mtrnump,mtrdenp,xmtrnum0,isig, + 2 2 4 4 0 6 0 0 +% +% npages,nsyst,musicsize,fracindent + 1 7 20 0.07 +Basso +Recorder +bt +./ +Abep +Iiharet60 +Tc +Francesco Barsanti (1690-1772) +%% +AeI1.1 +%2S9 +% Bar 1-4 +h +Adagio +c43 r8 f 65 f 42 e 6 r c | [ b 6 c ] d 7 b 65 c4 r8 c 65 t | + \global\figdrop5\Figu{-1}{\fsmsh}\Figu{0}{4}\Figu{4}{2}\ + c t bf4 65 x1842 a8 65 t a t #42 g 6 r g 65 t | + g t #42 f4 \global\figdrop8\ 65 x1842 \Figu06\ e8 d 54 dd1+ 3 c3 b8 6 g 7 / +g85 Gf ed1 d3 [ c3 a8+ gd1x5n s+1 f e d c s+1 ] Gc b8 s c s r e | + [ d35 s c d s e op ] e s d e s f op [ f s e f s g ] g f e f + Gf ed1 d3 c8 r ad1+ g3 | + [ fs15 dd+ ] [ c3 \nbbbbl2\ bf1x3 s+2 a g ] s+2 Gfn [ e1 cd+ ] [ b3 + \nbbbbl2\ a1x3 g f ] Ge ds8 ot e r ed1 dn3 | + [ cs15 ad+ ] [ g3 \nbbbbl2\ f1x3 s+2 e d s+2 ] + Gcn b1 c8 g1+ g3 s f e f s f8 op r1 f ed d3 / +% Bar 5-6 +[ c84 f- 7 ] g 4 g- 3 c ed1 f3 gd1 f3 ed1 d3 | cs4 5 r8 c 65 d4 r8 fd1 e3 / +[ e65 g c e s e1 s ] d6 c b a g f e d dd8 ot c1 c4 r8 ed1 f3 | + g85 gx3 s+1 fs g s+1 bf8 [ a3 s g fn e s ] [ f1 s d cs s d op ] + d s e f s gs op / +% Bar 7-8 +ds43 5 r8 d 65 e # ed1 fs3 gs8 e 7 | a4 r8 a 6 g4 7 r8 g 6 / +a85 ax3n+0+.7 s+2 gs a s+2 c8 bd1 ot a3 g1 Gfs ed8 r1 b+ bd ot a6 s b s | + c86x3 s+2 b a s+2 ax3 s+2 g f s+2 fx3 s+1 e f s+1 c+ + bx3 s+2 a g s+2 gx3 s+2 f e s+2 ex3nf+0+.7 s+2 ds e s+2 b+ / +% Bar 9-10 +f43 7 r8 d 65 e4 gs- 65 | a r r gs+ 65 / +a85x3 s+2 g f s+2 fx3 s+2 e d s+2 dx3nf+0+.7 s+2 cs d s+2 a+ + gs1 b d8 r1 d cd b3 s+0-.3 | + [ c1 s a s bf s gs s ] a s fs s gn s e s + [ fn s ds s e s cs s ] dn s f s e d s / +% Bar 11-12 +[ a83 d- 7 ] e 4 e- #3 a ad1+ b3 c8 gs 65 | a4 # cs- 65 d8 dd1 e3 f8 d / +c15 s+2 gs+ a s+1 d- Gc bd8 ot a1 a4 r8 ed1+ d3 | + cs1 e g bf [ a3 cs e1 s ] e6 s d s cn bf a g f e s + Ge fd1 e3 d8 ot r8 dd1 cn3 / +% Bar 13-14 +g43 b- 65 [-1+1 c8 cd1 d3 ] ef8 b 6 | c4 -3 bf n42 af 6 an #6 / +b14 d f a [ g3 b d1 t ] [+1 d6 t c b a g f e d ] + Gd ed1 ot d3 c8 r1 d dd ot c6 s d s | + ef1 c cd ot b6 s c s en1 c cd ot b6 s c s + f1 c cd ot b6 s c s fs1 c cd ot b6 s c s / +% Bar 15-end +b82 6 gd1 a3 b8 g 7 c4 -3 r | r2 r8 f e s 6 d s 6 | [-1 c f 7 g 4 g- 3 ] c2 / +g45 r1 af gd f3 ef1 bn+ s c s an s [ bf s g s af s fs s ] | + g s e s f s d s [ ef s c s df s bn s ] c8 s a op g op f+ s | + [ e s a- dd ot c1 ] c2 / diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex new file mode 100644 index 00000000000..fe003c3404e --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex @@ -0,0 +1,307 @@ +%%%%%%%%%%%%%%%%% +% +% barsant.tex +% +%%%%%%%%%%%%%%%% +\input musixtex +\input pmx +\def\fixdrop{\advance\sysno by 1\ifcase\sysno% +\figdrop= 5 \figdtwo= 4 \or% +\figdrop= 8 \figdtwo= 4 \or% +\figdrop= 5 \figdtwo= 4 \or% +\figdrop= 6 \figdtwo= 4 \or% +\figdrop= 7 \figdtwo= 4 \or% +\figdrop= 4 \figdtwo= 4 \or% +\figdrop= 6 \figdtwo= 4 \fi}% +\setmaxslurs{24}\setmaxinstruments{24}% +\input musixps +\normalmusicsize% +\nopagenumbers +\tracingstats=2\relax +\hsize=524pt +\vsize740pt +\def\nbinstruments{2} +\setstaffs11 +\setclef16 +\setname1{Basso} +\setstaffs21 +\setclef20 +\setname2{Recorder} +\generalsignature{ 0}% +\generalmeter\meterC% +\parindent 37pt +\elemskip1pt\afterruleskip1.000pt\beforeruleskip0pt\relax +\stafftopmarg0pt\staffbotmarg0pt\interstaff{7.9}\relax +\readmod{barsant} +\startmuflex\startpiece\addspace\afterruleskip% +\bigaccid% +\global\parskip 0pt plus 12\Interligne minus 99\Interligne% +\def\upstrut{\znotes&\zcharnote{\upamt}{~}\en}% +\Nosluradjust\Notieadjust\nohalfties +\global\parskip 0pt plus 12\Interligne minus 99\Interligne% +\def\upstrut{\znotes&\zcharnote{\upamt}{~}\en}% +\znotes&\zcharnote{16}{\titles{.2}{}{0}% +{}{.2}{Francesco Barsanti (1690-1772)}{.1}}\en% +% Bar count 1 +\fixdrop% +\starteq% +\pnotes{2.00}\qu{'C}&\zcharnote{16}{\bigfont\kern-30pt Adagio}% +\ibl2{'e}{-2}\qb2g\en% +\pnotes{1.75}&\shlft8{\zcu{'f}}\nbbl2\qbp2e\en% +\pnotes{1.05}\sk\ds&\tbbbl2\tbl2\qb2{'d}\ibbbl2e{-2}\rbbbl2\rbbl2\qb2c% +\en% +\pnotes{1.50}&\qb2{''a}\en% +\pnotes{0.50}\Figu0{6}\Figu4{5}\cl{'F}&\en% +\pnotes{0.83}&\isluru0{''a}\nbbbbl2\qb2{`g}\qb2f\qb2e\qb2d\tslur0d% +\tbl2\qb2c\en% +\pnotes{2.00}\ast{1.05}\Figu0{4}\Figu4{2}\ibl1{'F}{-1}\qb1F\Figu0{6}% +\tbl1\qb1E\ds\cu C&\ast{1.05}\ibl2{'b}1\isluru0b\shlft8{\zcu c}\qb2b% +\tslur0c\tbl2\qb2c\ds\cl e\en% +% Bar count 2 +\xbar +\pnotes{1.05}\Figu0{6}\ibu1{'B}1\qb1B\sk\sk\sk\tbu1\qb1C\sk\sk\sk\Figu0{% +7}\ibu1C{-1}\qb1D\sk\sk\sk\Figu0{6}\Figu4{5}\tbu1\qb1B&\ibbbl2{'d}0% +\isluru0d\qb2d\qb2c\tslur0d\qb2d\uppz e\tbl2\qb2e\ibbbl2e0\isluru0e\qb2e% +\qb2d\tslur0e\qb2e\uppz f\tbl2\qb2f\ibbbl2f0\isluru0f\qb2f\qb2e\tslur0f% +\qb2f\tbl2\qb2g\ibbbl2f0\qb2g\qb2f\qb2e\tbl2\qb2f\en% +\pnotes{1.75}\ast{.83}\qu{'C}&\ast{.83}\ibbl2{'e}{-2}\shlft8{\zcu f}% +\qbp2e\en% +\pnotes{1.05}&\tbbbl2\tbbl2\qb2{'d}\en% +\pnotes{2.00}\sk\ds&\tbl2\qb2{'c}\ds\en% +\pnotes{1.75}\Figu0{6}\Figu4{5}\tieforisd\islurd0{'C}\cu C&% +\ibbl2{''a}{-2}\qbp2a\en% +\pnotes{1.05}&\tbbbl2\tbl2\qb2{'g}\en% +% Bar count 3 +\fixdrop% +\alaligne +\pnotes{1.41}\global\figdrop5\Figu{-1}{\fsmsh}\Figu{0}{4}\Figu{4}{2}% +\tieforts\tslur0{'C}\cu C&\ibbl2{'g}9\bigsh f\qb2f\en% +\pnotes{1.15}&\tbl2\qbp2{''d}\en% +\pnotes{0.58}\Figu0{6}\Figu4{5}\bigfl{'B}\qu B&\en% +\pnotes{1.00}&\ibbbl2{''b}{-3}\qb2c\en% +\pnotes{0.82}&\ast{.36}\nbbbbl2\isluru0{''d}\fl b\xnum{0.82}c3\qb2b\qb2a% +\tslur0b\tbl2\qb2{`g}\en% +\pnotes{1.41}\Figu0{4}\Figu4{2}&\ast{1.24}\ibbl2{'f}9\shlft8{\bigna f\zcu% + f}\qb2e\en% +\pnotes{1.15}&\tbl2\qbp2{''c}\en% +\pnotes{0.58}\Figu0{6}\Figu4{5}\tieforisd\islurd0{'A}\cu A&\en% +\pnotes{1.00}&\ibbbl2{''a}{-3}\qb2b\en% +\pnotes{0.82}&\nbbbbl2\xnum{0.82}{''b}3\qb2a\qb2{`g}\tbl2\qb2f\en% +\pnotes{2.00}\ast{1.49}\Figu{-1}{\fsmsh}\Figu0{4}\Figu4{2}\ibu1{'A}{-1}% +\tieforts\tslur0A\qb1A\Figu0{6}\tbu1\qb1{`G}\ds&\ast{1.49}\ibl2{'d}1% +\shlft{13}{\zcu e}\shake g\sh d\qb2d\tbl2\qb2e\ds\en% +\pnotes{1.73}\Figu0{6}\Figu4{5}\tieforisd\islurd0G\cu G&\ibbl2{'e}{-1}% +\qbp2e\en% +\pnotes{1.00}&\bigna{'d}\tbbbl2\tbl2\qb2d\en% +% Bar count 4 +\xbar +\pnotes{1.41}\Figu{-1}{\fsmsh}\Figu0{4}\Figu4{2}\tieforts\tslur0G\cu G&% +\ibbl2{'d}9\bigsh c\qb2c\en% +\pnotes{1.15}&\tbl2\qbp2{''a}\en% +\pnotes{0.58}\Figu0{6}\Figu4{5}\qu F&\en% +\pnotes{1.00}&\ibbbl2{'f}{-3}\qb2g\en% +\pnotes{0.82}&\nbbbbl2\isluru0{''a}\xnum{0.82}{`g}3\qb2f\qb2e\tslur0f% +\tbl2\qb2d\en% +\pnotes{1.41}\Figu0{4}\Figu4{2}&\ast{1.24}\ibbl2{'c}4\shlft8{\bigna c\zcu% + c}\rbbl2\qb2b\en% +\pnotes{1.00}\sk\global\figdrop8\Figu06\cu E&\qb2{'c}\en% +\pnotes{1.41}&\tbbl2\tbl2\qb2{'g}\en% +\pnotes{1.00}\Figu0{5}\Figu4{4}\ibu1{'A}3\qb1{`D}&\ibbbl2{'f}0\isluru0g% +\qb2g\qb2f\qb2e\tslur0f\tbbbl2\tbbl2\qb2f\en% +\pnotes{1.73}\Figu0{3}\nbbu1\qbp1{'D}&\uppz{'f}\tbl2\qb2f\en% +\pnotes{1.00}\tbbbu1\tbu1\qb1{'C}&\en% +\pnotes{1.41}\Figu0{6}\ibu1{'B}{-2}\qb1B&\qs\ibbl2{'f}{-2}\qb2f\en% +\pnotes{1.73}\Figu0{7}\tbu1\qb1G&\qbp2{'e}\en% +\pnotes{1.00}&\tbbbl2\tbl2\qb2{'d}\en% +% Bar count 5 +\fixdrop% +\alaligne +\pnotes{0.81}\ibl1{''B}{-2}\qb1C&\ibbbbl2{'g}6\qb2e\qb2g\qb2{'c}% +\isluru0e\tbbbbl2\tbbbl2\qb2e\en% +\pnotes{1.48}&\tslur0{''e}\tbl2\qb2e\en% +\pnotes{0.81}\Figu0{7}\tbl1\qb1{'F}&\ibbbbl2{''b}{-4}\qb2d\qb2c\qb2b% +\qb2a\qb2{`g}\qb2f\qb2e\tbl2\qb2d\en% +\pnotes{2.00}\Figu0{4}\ibu1{'E}{-9}\qb1G&\ibl2{'d}{-1}\shake g\qbp2d\en% +\pnotes{1.00}\Figu0{3}\tbu1\qb1G&\en% +\pnotes{1.48}&\tbbl2\tbl2\qb2{'c}\en% +\pnotes{2.00}\ibl1{'D}2\qb1C&\ql{'c}\en% +\pnotes{1.77}\nbbl1\qbp1{'E}&\en% +\pnotes{1.10}\tbbbl1\tbl1\qb1{'F}&\en% +\pnotes{1.77}\ibbl1{'F}{-2}\qbp1G&\ds\en% +\pnotes{1.10}\tbbbl1\qb1{'F}&\en% +\pnotes{1.77}\qbp1{'E}&\ibbl2{'e}2\qbp2e\en% +\pnotes{1.10}\tbbbl1\tbl1\qb1{'D}&\tbbbl2\tbl2\qb2{'f}\en% +% Bar count 6 +\hardspace{ .4pt}% +\xbar +\pnotes{2.00}\Figu0{5}\bigsh{'C}\qu C&\cl{'g}\en% +\pnotes{1.24}&\xnum{1.37}{''a}3\ibbl2{`g}0\isluru0{'a}\qb2{`g}\ast{.15}% +\sh f\qb2f\tslur0{'a}\tbl2\qb2{`g}\en% +\pnotes{2.00}\ast{.15}\ds&\ast{.15}\fl{''b}\cl b\en% +\pnotes{1.10}\Figu0{6}\Figu4{5}\cu{'C}&\ibbbl2{'g}{-3}\isluru0{'a}\qb2a% +\qb2{`g}\ast{.29}\na f\qb2f\tslur0e\tbl2\qb2e\en% +\pnotes{1.48}\qu{'D}\sk\sk\sk\ds\sk\ibbl1F{-1}\qbp1F&\ibbl2{'d}0% +\isluru0f\qb2f\qb2d\tslur0c\bigsh c\qb2c\uppz e\tbl2\qb2d\ibbl2e2% +\isluru0d\qb2d\qb2e\tslur0f\qb2f\en% +\pnotes{0.74}&\uppz{'g}\bigsh g\tbl2\qb2g\en% +\pnotes{1.10}\tbbbl1\tbl1\qb1{'E}&\en% +% Bar count 7 +\fixdrop% +\alaligne +\pnotes{2.00}\ast{.54}\Figu0{5}\sh{'D}\qu D&\ast{.54}\cl{''a}\en% +\pnotes{1.70}&\xnum{3.28}{''b}3\ibbl2a0\isluru0c\qb2a\ast{1.12}\sh{`g}% +\qb2g\tslur0{'c}\tbl2\qb2a\en% +\pnotes{2.00}\ds&\ibl2{''b}{-3}\qb2c\en% +\pnotes{1.92}\Figu0{6}\Figu4{5}\cu{'D}&\shake{''d}\nbbl2\qbp2b\en% +\pnotes{1.63}&\ast{.65}\tbbbl2\tbl2\qb2{''a}\en% +\pnotes{1.80}\Figu{-1}{\sharpfig}\ibl1{'E}0\qb1E&\ibbl2{'g}{-6}% +\rbbl2\qb2g\en% +\pnotes{1.00}&\ast{2.47}\shlft8{\bigsh{'f}\zcu f}\tbl2\qbp2e\en% +\pnotes{1.92}\nbbl1\qbp1{'E}&\en% +\pnotes{1.63}\ast{1.80}\sh{'F}\tbbbl1\tbl1\qb1F&\en% +\pnotes{1.80}\ast{1.19}\ibl1{'G}{-3}\sh G\qb1G&\ast{1.19}\qs\ibbl2{''a}0% +\qb2b\en% +\pnotes{1.92}\Figu0{7}\tbl1\qb1{'E}&\shake{''d}\qbp2b\en% +\pnotes{1.47}&\ast{.65}\isluru0{''a}\nbbbbl2\qb2a\tslur0b\tbl2\qb2b\en% +% Bar count 8 +\xbar +\pnotes{1.70}\ql{''A}\sk\sk\sk\sk\sk\ds&\xnum{1.70}{''d}3\ibbl2b{-3}% +\isluru0e\qb2c\qb2b\tslur0c\tbl2\qb2a\xnum{1.70}b3\ibbl2{`g}{-3}% +\isluru0{'c}\qb2a\qb2{`g}\tslur0{'a}\tbl2\qb2{`f}\xnum{1.70}g3\ibbl2f0% +\isluru0g\qb2f\qb2e\tslur0g\tbl2\qb2f\en% +\pnotes{2.00}\Figu0{6}\cl{''A}&\cl{''c}\en% +\pnotes{1.70}\Figu0{7}\ql{'G}\sk\sk\sk\sk\sk\ds&% +\xnum{1.70}{''c}3\ibbl2a{-3}\isluru0d\qb2b\qb2a\tslur0b\tbl2\qb2{`g}% +\xnum{1.70}{'a}3\ibbl2{`f}{-3}\isluru0{'b}\qb2{`g}\qb2f\tslur0g% +\tbl2\qb2e\xnum{3.28}f3\ibbl2e0\isluru0g\qb2e\ast{1.12}\sh d\qb2d\tslur0g% +\tbl2\qb2e\en% +\pnotes{2.00}\Figu0{6}\cl{'G}&\cl{''b}\en% +% Bar count 9 +\xbar +\pnotes{1.70}\Figu0{7}\ql{'F}\sk\sk\sk\sk\sk\ds&% +\xnum{1.70}{''b}3\ibbl2{`g}{-3}\isluru0{'c}\qb2a\qb2{`g}\tslur0{'a}% +\tbl2\qb2{`f}\xnum{1.70}g3\ibbl2e{-3}\isluru0{'a}\qb2{`f}\qb2e\tslur0f% +\tbl2\qb2d\xnum{3.28}e3\ibbl2d0\isluru0f\qb2d\ast{1.12}\sh c\qb2c\tslur0f% +\tbl2\qb2d\en% +\pnotes{2.00}\Figu0{6}\Figu4{5}\cu{'D}&\cl{''a}\en% +\pnotes{1.80}\ast{.82}\ql{'E}&\ast{.82}\ibbl2{''a}6\sh{`g}\qb2g% +\tbbl2\qb2{'b}\en% +\pnotes{2.00}&\tbl2\qb2{''d}\en% +\pnotes{1.80}\Figu0{6}\Figu4{5}\bigsh G\qu G&\qs\ibbl2{''c}0\qb2d\en% +\pnotes{1.92}&\qbp2{''c}\en% +\pnotes{1.63}&\ast{.65}\isu0{''b}{-.3}\tbbbl2\tbl2\qb2b\en% +% Bar count 10 +\fixdrop% +\def\raisebarno{7.5\internote}% +\alaligne +\def\raisebarno{3.5\internote}% +\pnotes{1.77}\qu{'A}\sk\sk\sk\ast{1.44}\ast{1.44}\qp\sk\sk\sk\ast{1.44}% +\ast{1.44}\ast{1.44}\qp\sk\sk\sk\ast{1.44}\ast{1.44}\ast{1.44}\Figu0{6}% +\Figu4{5}\bigsh G\ql G&\ibbl2{''b}{-1}\tslur0c\qb2c\isluru0a\qb2a% +\ast{1.44}\tslur0b\fl b\qb2b\ast{1.44}\isluru0{`g}\sh g\tbl2\qb2g% +\ibbl2g{-1}\tslur0{'a}\qb2a\ast{1.44}\isluru0{`f}\sh f\qb2f\ast{1.44}% +\tslur0g\na g\qb2g\isluru0e\tbl2\qb2e\ast{1.44}\ibbl2e{-1}\tslur0f\na f% +\qb2f\ast{1.44}\isluru0d\sh d\qb2d\tslur0e\qb2e\ast{1.44}\isluru0c\sh c% +\tbl2\qb2c\ast{1.44}\ibbl2e0\tslur0d\na d\qb2d\isluru0f\qb2f\qb2e\tslur0d% +\tbl2\qb2d\en% +% Bar count 11 +\xbar +\pnotes{1.77}\ibl1{'G}{-6}\qb1{'A}\sk\ast{1.44}\Figu0{7}\tbl1\qb1{`D}&% +\ibbl2{'e}1\isluru0e\qb2c\ast{1.44}\sh g\qb2g\tslur0{'b}\qb2a% +\tbl2\qb2{`d}\en% +\pnotes{2.00}\ast{2.36}\Figu0{4}\ibu1{'C}{-9}\qb1E&\ast{2.36}\ibu2{'b}{-2}% +\shlft8{\zcu c}\shake{'c}\qbp2{`b}\en% +\pnotes{1.00}\Figu{-1}{\fsmsh}\Figu0{3}\tbu1\qb1E&\en% +\pnotes{1.77}&\tbbu2\tbu2\qb2{'a}\en% +\pnotes{2.00}\ibl1{'C}9\qb1A&\qu{'a}\en% +\pnotes{1.90}\nbbl1\qbp1{''A}&\en% +\pnotes{1.56}\ast{1.01}\tbbbl1\tbl1\qb1{''B}&\en% +\pnotes{2.00}\ibl1{''B}{-7}\qb1C&\ds\en% +\pnotes{1.90}\ast{1.20}\Figu0{6}\Figu4{5}\sh{'G}\tbl1\qb1G&\ast{1.20}% +\ibbl2{'e}{-3}\qbp2e\en% +\pnotes{1.56}&\ast{1.01}\tbbbl2\tbl2\qb2{'d}\en% +% Bar count 12 +\xbar +\pnotes{1.77}\ast{.75}\Figu{-1}{\sharpfig}\ql{''A}&\ast{.75}\ibbl2{'d}6% +\sh c\qb2c\qb2e\qb2g\ast{1.44}\fl{'b}\tbl2\qb2b\en% +\pnotes{1.56}\Figu0{6}\Figu4{5}\bigsh{'C}\qu C&\ibbbl2{''b}6\qb2a% +\ast{1.64}\sh c\tbbbl2\qb2c\en% +\pnotes{1.77}&\isluru0{''e}\tbl2\qb2e\en% +\pnotes{1.38}&\ibbbbl2{''c}{-4}\tslur0e\qb2e\isluru0d\qb2d\ast{1.82}\na c% +\qb2c\ast{1.82}\fl b\qb2b\qb2a\qb2{`g}\qb2f\tslur0e\tbl2\qb2e\en% +\pnotes{1.90}\ast{2.74}\ibl1{'D}0\qb1D&\ast{2.74}\ibbl2{'f}{-3}\shlft8{% +\zcu e}\qbp2f\en% +\pnotes{1.56}&\ast{1.01}\tbbbl2\tbbl2\qb2{'e}\en% +\pnotes{1.90}\nbbl1\qbp1{'D}&\shake{'g}\tbl2\qb2d\en% +\pnotes{1.56}\ast{1.01}\tbbbl1\tbl1\qb1{'E}&\en% +\pnotes{2.00}\ibl1{'F}{-5}\qb1F&\ds\en% +\pnotes{1.90}\tbl1\qb1{'D}&\ibbl2{'d}{-3}\qbp2d\en% +\pnotes{1.56}&\ast{2.32}\na{'c}\tbbbl2\tbl2\qb2c\en% +% Bar count 13 +\fixdrop% +\alaligne +\endeq% +\pnotes{1.48}\ql{'G}&\ibbl2{'d}4\qb2b\qb2d\qb2f\tbl2\qb2{'a}\en% +\pnotes{1.14}\Figu0{6}\Figu4{5}\qu{'B}&\ibbbl2{''a}5\qb2{`g}% +\tbbbl2\qb2{'b}\en% +\pnotes{1.48}&\tieforisu\isluru0{''d}\tbl2\qb2d\en% +\pnotes{0.88}&\ibbbbl2{''c}{-4}\tieforts\tslur0d\qb2d\qb2c\qb2b\qb2a% +\qb2{`g}\qb2f\qb2e\tbl2\qb2d\en% +\pnotes{1.73}\ast{1.13}\ibu1{'C}1\qb1C&\ast{1.13}\ibbl2{'d}{-2}\shlft8{% +\zcu d}\shake g\qbp2e\en% +\pnotes{1.14}&\tbbbl2\tbbl2\qb2{'d}\en% +\pnotes{1.73}\nbbu1\qbp1{'C}&\tbl2\qb2{'c}\en% +\pnotes{1.14}\tbbbu1\tbu1\qb1{'D}&\en% +\pnotes{1.48}\ast{.42}\ibu1{'D}{-3}\fl E\qb1E&\ast{.42}\qs\ibbl2{'c}0% +\qb2d\en% +\pnotes{1.73}\Figu0{6}\tbu1\qb1{'B}&\shake{'g}\qbp2d\en% +\pnotes{0.88}&\isluru0{'c}\nbbbbl2\qb2c\tslur0d\tbl2\qb2d\en% +% Bar count 14 +\xbar +\pnotes{1.48}\Figu{-1}{\fsmfl}\Figu0{3}\qu{'C}&\ibbl2{'b}0\bigfl e\qb2e% +\qb2c\en% +\pnotes{1.73}&\shake{'g}\qbp2c\en% +\pnotes{0.88}&\isluru0{'b}\nbbbbl2\qb2b\tslur0c\tbl2\qb2c\en% +\pnotes{1.48}\ast{.68}\Figu{-1}{\fsmna}\Figu0{4}\Figu4{2}\bigfl{'B}\qu B% +&\ast{.68}\ibbl2{'b}0\na e\qb2e\qb2c\en% +\pnotes{1.73}&\shake{'g}\qbp2c\en% +\pnotes{0.88}&\isluru0{'b}\nbbbbl2\qb2b\tslur0c\tbl2\qb2c\en% +\pnotes{1.48}\Figu0{6}\bigfl{'A}\qu A&\ibbl2{'b}0\qb2f\qb2c\en% +\pnotes{1.73}&\shake{'g}\qbp2c\en% +\pnotes{0.88}&\isluru0{'b}\nbbbbl2\qb2b\tslur0c\tbl2\qb2c\en% +\pnotes{1.48}\ast{.68}\Figu{-1}{\fsmsh}\Figu0{6}\bigna{'A}\qu A&% +\ast{.68}\ibbl2{'b}0\sh f\qb2f\qb2c\en% +\pnotes{1.73}&\shake{'g}\qbp2c\en% +\pnotes{0.88}&\isluru0{'b}\nbbbbl2\qb2b\tslur0c\tbl2\qb2c\en% +% Bar count 15 +\fixdrop% +\alaligne +\pnotes{2.00}\Figu0{6}\ibu1{'B}{-1}\qb1B&\ql{'g}\en% +\pnotes{1.73}\nbbu1\qbp1G&\en% +\pnotes{1.00}\tbbbu1\tbu1\qb1{'A}&\en% +\pnotes{1.41}\ibu1{'A}{-2}\qb1B&\qs\ast{.11}\ibbl2{''a}{-2}\fl a\qb2a\en% +\pnotes{1.73}\Figu0{7}\tbu1\qb1G&\qbp2{'g}\en% +\pnotes{1.00}&\tbbbl2\tbl2\qb2{'f}\en% +\pnotes{1.41}\ast{.53}\Figu{-1}{\fsmfl}\Figu0{3}\qu{'C}\sk\sk\sk% +\ast{.11}\ast{.11}\ast{.11}\qp&\ast{.53}\ibbl2{'g}2\fl e\qb2e\ast{.11}% +\isluru0{'b}\na b\qb2b\tslur0c\qb2c\ast{.11}\isluru0a\na a\tbl2\qb2a% +\ast{.11}\ibbl2a{-1}\tslur0b\fl b\qb2b\isluru0{`g}\qb2g\ast{.11}% +\tslur0{'a}\fl a\qb2a\ast{.11}\isluru0{`f}\sh f\tbl2\qb2f\en% +% Bar count 16 +\xbar +\pnotes{1.41}\hpause&\ibbl2{'f}{-1}\tslur0g\qb2g\isluru0e\qb2e\tslur0f% +\qb2f\isluru0d\tbl2\qb2d\ast{.11}\ibbl2d{-1}\tslur0e\fl e\qb2e\isluru0c% +\qb2c\ast{.11}\tslur0d\fl d\qb2d\ast{.11}\isluru0b\na b\tbl2\qb2b\en% +\pnotes{2.00}\ds\ibl1{'F}{-2}\qb1F\Figu0{6}\isluru1E\qb1E\Figu0{6}% +\tslur1D\tbl1\qb1D&\ibl2{'a}2\tslur0c\qb2c\uppz e\qb2a\uppz e\qb2{`g}% +\isluru0{'f}\tbl2\qb2f\en% +% Bar count 17 +\xbar +\pnotes{2.00}\ibu1{'E}{-2}\qb1C\Figu0{7}\qb1F\Figu0{4}\qb1G&% +\ibl2{'c}{-1}\tslur0e\qb2e\qb2a\shake g\qbp2d\en% +\pnotes{1.00}\Figu0{3}\tbu1\qb1G&\en% +\pnotes{1.41}&\tbbl2\tbl2\qb2{'c}\en% +\pnotes{4.00}\hu{'C}&\hl{'c}\en% +\Endpiece +\vskip .1\Interligne\eject\endmuflex +\bye diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx new file mode 100644 index 00000000000..2aea3d406eb --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx @@ -0,0 +1,48 @@ +%----------------% +% +% barsant.pmx Revised 29 June 2002 +% +%----------------% +% +% nv,noinst,mtrnuml,mtrdenl,mtrnump,mtrdenp,xmtrnum0,isig, + 1 + 1 + 4 + 4 + 0 + 6 + .00 + 0 +% +% npages,nsyst,musicsize,fracindent + 1 + 7 + 20 + .05 + +b +./ +Ti +Basso +Abep +Tc +Francesco Barsanti (1690-1772) +% Bar 1-4 +h +Adagio +c43 r8 f 65 f 42 e 6 r c | [ b 6 c ] d 7 b 65 c4 r8 c 65 t | +\global\figdrop5\Figu{-1}{\fsmsh}\Figu{0}{4}\Figu{4}{2}\ +c t bf4 65 x1842 a8 65 t a t #42 g 6 r g 65 t | +g t #42 f4 \global\figdrop8\ 65 x1842 \Figu06\ e8 d 54 dd1+ 3 c3 b8 6 g 7 / +% Bar 5-6 +[ c84 f- 7 ] g 4 g- 3 c ed1 f3 gd1 f3 ed1 d3 | cs4 5 r8 c 65 d4 r8 fd1 e3 / +% Bar 7-8 +ds43 5 r8 d 65 e # ed1 fs3 gs8 e 7 | a4 r8 a 6 g4 7 r8 g 6 / +% Bar 9-10 +f43 7 r8 d 65 e4 gs- 65 | a r r gs+ 65 / +% Bar 11-12 +[ a83 d- 7 ] e 4 e- #3 a ad1+ b3 c8 gs 65 | a4 # cs- 65 d8 dd1 e3 f8 d / +% Bar 13-14 +g43 b- 65 [-1+1 c8 cd1 d3 ] ef8 b 6 | c4 -3 bf n42 af 6 an #6 / +% Bar 15-end +b82 6 gd1 a3 b8 g 7 c4 -3 r | r2 r8 f e s 6 d s 6 | [-1 c f 7 g 4 g- 3 ] c2 / diff --git a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx new file mode 100644 index 00000000000..a21386f4768 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx @@ -0,0 +1,66 @@ +%----------------% +% +% barsant.pmx Revised 29 June 2002 +% +%----------------% +% +% nv,noinst,mtrnuml,mtrdenl,mtrnump,mtrdenp,xmtrnum0,isig, + 1 + 1 + 4 + 4 + 0 + 6 + .00 + 0 +% +% npages,nsyst,musicsize,fracindent + 1 + 7 + 20 + .05 + +t +./ +Ti +Recorder +Abep +Tc +Francesco Barsanti (1690-1772) +S9 +% Bar 1-4 +h +Adagio +g85 Gf ed1 d3 [ c3 a8+ gd1x5n s+1 f e d c s+1 ] Gc b8 s c s r e | +[ d35 s c d s e op ] e s d e s f op [ f s e f s g ] g f e f +Gf ed1 d3 c8 r ad1+ g3 | +[ fs15 dd+ ] [ c3 \nbbbbl2\ bf1x3 s+2 a g ] s+2 Gfn [ e1 cd+ ] [ b3 +\nbbbbl2\ a1x3 g f ] Ge ds8 ot e r ed1 dn3 | +[ cs15 ad+ ] [ g3 \nbbbbl2\ f1x3 s+2 e d s+2 ] +Gcn b1 c8 g1+ g3 s f e f s f8 op r1 f ed d3 / +% Bar 5-6 +[ e65 g c e s e1 s ] d6 c b a g f e d dd8 ot c1 c4 r8 ed1 f3 | +g85 gx3 s+1 fs g s+1 bf8 [ a3 s g fn e s ] [ f1 s d cs s d op ] +d s e f s gs op / +% Bar 7-8 +a85 ax3n+0+.7 s+2 gs a s+2 c8 bd1 ot a3 g1 Gfs ed8 r1 b+ bd ot a6 s b s | +c86x3 s+2 b a s+2 ax3 s+2 g f s+2 fx3 s+1 e f s+1 c+ +bx3 s+2 a g s+2 gx3 s+2 f e s+2 ex3nf+0+.7 s+2 ds e s+2 b+ / +% Bar 9-10 +a85x3 s+2 g f s+2 fx3 s+2 e d s+2 dx3nf+0+.7 s+2 cs d s+2 a+ +gs1 b d8 r1 d cd b3 s+0-.3 | +[ c1 s a s bf s gs s ] a s fs s gn s e s +[ fn s ds s e s cs s ] dn s f s e d s / +% Bar 11-12 +c15 s+2 gs+ a s+1 d- Gc bd8 ot a1 a4 r8 ed1+ d3 | +cs1 e g bf [ a3 cs e1 s ] e6 s d s cn bf a g f e s +Ge fd1 e3 d8 ot r8 dd1 cn3 / +% Bar 13-14 +b14 d f a [ g3 b d1 t ] [+1 d6 t c b a g f e d ] +Gd ed1 ot d3 c8 r1 d dd ot c6 s d s | +ef1 c cd ot b6 s c s en1 c cd ot b6 s c s +f1 c cd ot b6 s c s fs1 c cd ot b6 s c s / +% Bar 15-end +g45 r1 af gd f3 ef1 bn+ s c s an s [ bf s g s af s fs s ] | +g s e s f s d s [ ef s c s df s bn s ] c8 s a op g op f+ s | +[ e s a- dd ot c1 ] c2 / diff --git a/Build/source/utils/pmx/pmx-2.6.18/version.ac b/Build/source/utils/pmx/pmx-2.6.18/version.ac new file mode 100644 index 00000000000..cdb0e0b0dbe --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/version.ac @@ -0,0 +1,11 @@ +dnl +dnl Copyright (C) 2012 Peter Breitenlohner +dnl +dnl This file is free software; the copyright holder +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. +dnl +dnl -------------------------------------------------------- +dnl +dnl m4-include this file to define the current pmx version +m4_define([pmx_version], [2.6.18]) diff --git a/Build/source/utils/pmx/pmx-2.6.18/w32getc.c b/Build/source/utils/pmx/pmx-2.6.18/w32getc.c new file mode 100644 index 00000000000..32f9d625953 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.18/w32getc.c @@ -0,0 +1,14 @@ +#include +int w32getc(FILE *f) +{ + int c; + c = getc(f); + if(c=='\r') { + c = getc(f); + if(c!='\n') { + ungetc(c,f); + c='\r'; + } + } + return c; +} diff --git a/Build/source/utils/pmx/tests/barsant.mid b/Build/source/utils/pmx/tests/barsant.mid index 48190b2ddac..ccd7219e2be 100644 Binary files a/Build/source/utils/pmx/tests/barsant.mid and b/Build/source/utils/pmx/tests/barsant.mid differ diff --git a/Build/source/utils/pmx/tests/barsant.pml b/Build/source/utils/pmx/tests/barsant.pml index d219f240277..0c514716522 100644 --- a/Build/source/utils/pmx/tests/barsant.pml +++ b/Build/source/utils/pmx/tests/barsant.pml @@ -1,4 +1,4 @@ -This is PMX, Version 2617 , 28 Jan 12 +This is PMX, Version 2618 , 19 Mar 12 Opening barsant.pmx Starting first PMX pass diff --git a/Build/source/utils/pmx/version.ac b/Build/source/utils/pmx/version.ac index d1cb4fdeb94..cdb0e0b0dbe 100644 --- a/Build/source/utils/pmx/version.ac +++ b/Build/source/utils/pmx/version.ac @@ -8,4 +8,4 @@ dnl dnl -------------------------------------------------------- dnl dnl m4-include this file to define the current pmx version -m4_define([pmx_version], [2.6.17]) +m4_define([pmx_version], [2.6.18]) -- cgit v1.2.3