From 1edf6b64eb5ea6b65099076e92bccb6a90d2d88b Mon Sep 17 00:00:00 2001 From: Peter Breitenlohner Date: Fri, 18 Jan 2013 08:05:40 +0000 Subject: pmx 2.6.19 git-svn-id: svn://tug.org/texlive/trunk@28860 c570f23f-e606-0410-a88d-b1316a301751 --- .../source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog | 37 - .../source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes | 13 - .../utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary | 17 - .../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 - .../utils/pmx/pmx-2.6.18-PATCHES/patch-06-WIN32 | 89 - .../utils/pmx/pmx-2.6.18-PATCHES/patch-07-test | 45 - 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 | 239 - 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/configure.ac | 42 - Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c | 22 - .../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 | 233 - .../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 | 149 - 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 | 64 - 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 | 803 - 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 | 302 - 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 | 615 - 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 | 26 - 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.for | 1620 - .../source/utils/pmx/pmx-2.6.18/scor2prt.for.orig | 1619 - .../source/utils/pmx/pmx-2.6.18/tests/barsant.mid | Bin 3077 -> 0 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 - .../source/utils/pmx/pmx-2.6.19-PATCHES/TL-Changes | 1 + 200 files changed, 1 insertion(+), 104615 deletions(-) delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-06-WIN32 delete mode 100644 Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-07-test delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/AUTHORS delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/COPYING delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/ChangeLog delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/INSTALL delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/Makefile.am delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/NEWS delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/README delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/configure.ac delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/getenv_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sfe.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wref.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c delete mode 100755 Build/source/utils/pmx/pmx-2.6.18/pmx.test delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmx2618.for delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/pmxab.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.c delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.for delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/version.ac delete mode 100644 Build/source/utils/pmx/pmx-2.6.18/w32getc.c (limited to 'Build/source/utils/pmx') diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog deleted file mode 100644 index 2572d4a1cb0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog +++ /dev/null @@ -1,37 +0,0 @@ -2012-07-12 Peter Breitenlohner - - * patch-07-test (new): Use the same test script in TeX Live and - for the stand-alone version. - -2012-07-11 Peter Breitenlohner - - * patch-06-WIN32 (new): Build fix for MSVC (from W32TeX). - We pass -DMSDOS to MSVC or -DUSE_CLOCK to the MinGW compiler. - -2012-05-19 Peter Breitenlohner - - Imported pmx-2.6.18 source tree from: - http://www.ctan.org/tex-archive/support/pmx/ - * patch-02-bugfix (removed): Obsolete. - * patch-01-binary, patch-03-DOS-line-endings, - patch-04-MSVC-complex, patch-05-FreeBSD-off_t: Adapted. - -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 deleted file mode 100644 index de64539b668..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes +++ /dev/null @@ -1,13 +0,0 @@ -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 - f2c.h - install-sh - missing - arith.h - 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 deleted file mode 100644 index 64947854a75..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary +++ /dev/null @@ -1,17 +0,0 @@ - On Windows fseek() etc. are meaningful only for binary access. - - Mail from Akira, 29 Mar 2012 23:50:53. - -diff -ur pmx-2.6.18.orig/libf2c/open.c pmx-2.6.18/libf2c/open.c ---- pmx-2.6.18.orig/libf2c/open.c 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/open.c 2012-05-19 18:46:29.225582726 +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-03-DOS-line-endings b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings deleted file mode 100644 index 1332d7c63dd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings +++ /dev/null @@ -1,18 +0,0 @@ - Handle DOS line endings (using additional file ../w32getc.c). - - Mail from Akira, 31 Mar 2012 21:36:26. - -diff -ur pmx-2.6.18.orig/libf2c/fio.h pmx-2.6.18/libf2c/fio.h ---- pmx-2.6.18.orig/libf2c/fio.h 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/fio.h 2012-05-19 18:47:56.503874316 +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 deleted file mode 100644 index a536dbbf03e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex +++ /dev/null @@ -1,18 +0,0 @@ - _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.18.orig/libf2c/f2c.h pmx-2.6.18/libf2c/f2c.h ---- pmx-2.6.18.orig/libf2c/f2c.h 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/f2c.h 2012-05-19 18:49:12.286432193 +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 deleted file mode 100644 index c26347aec6d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t +++ /dev/null @@ -1,13 +0,0 @@ - On FreeBSD (and maybe others) we need for off_t. - -diff -ur pmx-2.6.18.orig/libf2c/fio.h pmx-2.6.18/libf2c/fio.h ---- pmx-2.6.18.orig/libf2c/fio.h 2012-05-19 18:47:56.000000000 +0200 -+++ pmx-2.6.18/libf2c/fio.h 2012-05-19 18:50:13.501421172 +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-PATCHES/patch-06-WIN32 b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-06-WIN32 deleted file mode 100644 index 9ae41bfb5c0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-06-WIN32 +++ /dev/null @@ -1,89 +0,0 @@ - Typedef signed and unsigned 64-bit integers for MSVC. - Avoid the problematic prototypes for isatty() and ungetc(). - Avoid redefinition of max(a,b) and min(a,b). - -diff -ur pmx-2.6.18.orig/libf2c/f2c.h pmx-2.6.18/libf2c/f2c.h ---- pmx-2.6.18.orig/libf2c/f2c.h 2012-05-19 18:49:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/f2c.h 2012-07-11 17:17:59.000000000 +0200 -@@ -23,8 +23,13 @@ - typedef char logical1; - typedef char integer1; - #ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ -+#if defined(WIN32) && !defined(__MINGW32__) -+typedef __int64 longint; /* system-dependent */ -+typedef unsigned __int64 ulongint; /* system-dependent */ -+#else - typedef long long longint; /* system-dependent */ - typedef unsigned long long ulongint; /* system-dependent */ -+#endif - #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) - #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) - #endif -@@ -159,6 +164,8 @@ - - #define abs(x) ((x) >= 0 ? (x) : -(x)) - #define dabs(x) (doublereal)abs(x) -+#undef min -+#undef max - #define min(a,b) ((a) <= (b) ? (a) : (b)) - #define max(a,b) ((a) >= (b) ? (a) : (b)) - #define dmin(a,b) (doublereal)min(a,b) -diff -ur pmx-2.6.18.orig/libf2c/fio.h pmx-2.6.18/libf2c/fio.h ---- pmx-2.6.18.orig/libf2c/fio.h 2012-05-19 18:50:13.000000000 +0200 -+++ pmx-2.6.18/libf2c/fio.h 2012-07-11 17:46:22.000000000 +0200 -@@ -3,6 +3,9 @@ - #endif - #include /* for off_t */ - #include "stdio.h" -+#ifdef HAVE_UNISTD_H -+#include /* for isatty() */ -+#endif - #ifdef WIN32 - extern int w32getc(FILE *f); - #define getc w32getc -@@ -113,7 +116,6 @@ - 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); -diff -ur pmx-2.6.18.orig/libf2c/getenv_.c pmx-2.6.18/libf2c/getenv_.c ---- pmx-2.6.18.orig/libf2c/getenv_.c 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/getenv_.c 2012-07-12 13:28:57.000000000 +0200 -@@ -1,8 +1,10 @@ - #include "f2c.h" --#undef abs - #ifdef KR_headers - extern char *F77_aloc(), *getenv(); - #else -+#undef abs -+#undef max -+#undef min - #include - #include - #ifdef __cplusplus -diff -ur pmx-2.6.18.orig/libf2c/lread.c pmx-2.6.18/libf2c/lread.c ---- pmx-2.6.18.orig/libf2c/lread.c 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/lread.c 2012-07-11 17:23:48.000000000 +0200 -@@ -74,8 +74,6 @@ - #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 - -diff -ur pmx-2.6.18.orig/libf2c/rsne.c pmx-2.6.18/libf2c/rsne.c ---- pmx-2.6.18.orig/libf2c/rsne.c 2012-04-09 18:24:12.000000000 +0200 -+++ pmx-2.6.18/libf2c/rsne.c 2012-07-11 17:23:51.000000000 +0200 -@@ -66,7 +66,6 @@ - { return ungetc(x,f__cf); } - #else - #define un_getc ungetc --extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ - #endif - #endif - diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-07-test b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-07-test deleted file mode 100644 index 259307367f8..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-07-test +++ /dev/null @@ -1,45 +0,0 @@ -diff -ur pmx-2.6.18.orig/Makefile.am pmx-2.6.18/Makefile.am ---- pmx-2.6.18.orig/Makefile.am 2012-04-25 19:41:24.000000000 +0200 -+++ pmx-2.6.18/Makefile.am 2012-07-12 15:53:22.341219739 +0200 -@@ -226,6 +226,7 @@ - ## Tests - ## - TESTS = pmx.test -+TESTS_ENVIRONMENT = test_src=$(srcdir)/tests - EXTRA_DIST = $(TESTS) - - PATCHES = PATCH-2.6.18-01 PATCH-2.6.18-02 -diff -ur pmx-2.6.18.orig/pmx.test pmx-2.6.18/pmx.test ---- pmx-2.6.18.orig/pmx.test 2012-04-23 23:36:53.000000000 +0200 -+++ pmx-2.6.18/pmx.test 2012-05-19 21:44:30.000000000 +0200 -@@ -5,21 +5,22 @@ - - rm -f barsant* pmxaerr.dat - --cp $srcdir/tests/barsant.pmx . -+cp $test_src/barsant.pmx . - - failed= - - ./scor2prt barsant \ -- && diff barsant1.pmx $srcdir/tests/barsant1.pmx \ -- && diff barsant2.pmx $srcdir/tests/barsant2.pmx \ -- || failed="$failed scor2prt" -+ && diff barsant1.pmx $test_src/barsant1.pmx \ -+ && diff barsant2.pmx $test_src/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" -+ && diff barsant.mid $test_src/barsant.mid \ -+ && diff barsant.pml $test_src/barsant.pml \ -+ && diff barsant.tex $test_src/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/AUTHORS b/Build/source/utils/pmx/pmx-2.6.18/AUTHORS deleted file mode 100644 index 2fa3681a96f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/AUTHORS +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index 92bc3d8dc11..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/COPYING +++ /dev/null @@ -1,622 +0,0 @@ - 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 deleted file mode 100644 index a6bdd7ee272..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/ChangeLog +++ /dev/null @@ -1,206 +0,0 @@ -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 deleted file mode 100644 index 7d1c323beae..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/INSTALL +++ /dev/null @@ -1,365 +0,0 @@ -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 deleted file mode 100644 index 39584c503bd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/Makefile.am +++ /dev/null @@ -1,239 +0,0 @@ -## 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 -TESTS_ENVIRONMENT = test_src=$(srcdir)/tests -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 deleted file mode 100644 index 533cebce439..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/NEWS +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index 79b6bf23c46..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-01 +++ /dev/null @@ -1,40 +0,0 @@ -*** 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 deleted file mode 100644 index ea95290e8ed..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/PATCH-2.6.18-02 +++ /dev/null @@ -1,31 +0,0 @@ -*** 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 deleted file mode 100644 index 3e5060616d4..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/README +++ /dev/null @@ -1,11 +0,0 @@ -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/configure.ac b/Build/source/utils/pmx/pmx-2.6.18/configure.ac deleted file mode 100644 index d56db2ca306..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/configure.ac +++ /dev/null @@ -1,42 +0,0 @@ -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/abort_.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c deleted file mode 100644 index fa5aae6b716..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/abort_.c +++ /dev/null @@ -1,22 +0,0 @@ -#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/backspac.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c deleted file mode 100644 index 908a61897aa..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/backspac.c +++ /dev/null @@ -1,76 +0,0 @@ -#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 deleted file mode 100644 index 858f2c8b4b1..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_abs.c +++ /dev/null @@ -1,20 +0,0 @@ -#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 deleted file mode 100644 index 29fe49e3cda..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_cos.c +++ /dev/null @@ -1,23 +0,0 @@ -#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 deleted file mode 100644 index 59425e7aaad..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_div.c +++ /dev/null @@ -1,53 +0,0 @@ -#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 deleted file mode 100644 index f46508d35b1..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_exp.c +++ /dev/null @@ -1,25 +0,0 @@ -#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 deleted file mode 100644 index a0ba3f0d8d2..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_log.c +++ /dev/null @@ -1,23 +0,0 @@ -#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 deleted file mode 100644 index c8bc30f2d69..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sin.c +++ /dev/null @@ -1,23 +0,0 @@ -#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 deleted file mode 100644 index 1678c534d60..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/c_sqrt.c +++ /dev/null @@ -1,41 +0,0 @@ -#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 deleted file mode 100644 index 84750d505cf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/cabs.c +++ /dev/null @@ -1,33 +0,0 @@ -#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 deleted file mode 100644 index e958c7172a8..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/close.c +++ /dev/null @@ -1,101 +0,0 @@ -#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 deleted file mode 100644 index 69005b56d76..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_acos.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index d5196ab101e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_asin.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index d8856f8d698..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atan.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 56113850ab9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_atn2.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 38471d9bc0e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cnjg.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 12def9ad0fd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cos.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 9214c7a0d82..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_cosh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 627ddb690fd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index e9ab5d4425c..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_exp.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index d17b9dd591d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_imag.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 6da4ce35e92..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_int.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 664c19d9e99..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_lg10.c +++ /dev/null @@ -1,21 +0,0 @@ -#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 deleted file mode 100644 index e74be02c54e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_log.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 3766d9fa828..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_mod.c +++ /dev/null @@ -1,46 +0,0 @@ -#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 deleted file mode 100644 index 66f2dd0ee67..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_nint.c +++ /dev/null @@ -1,20 +0,0 @@ -#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 deleted file mode 100644 index f9f348b03dd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_prod.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index d06e0d19231..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index ebd4eec5eeb..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sin.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 2479a6fab22..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sinh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index a7fa66c00aa..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_sqrt.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 7d252c4d5cf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tan.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 415b58508b3..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/d_tanh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index d935d315213..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/derf_.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 18f5c619b6f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/derfc_.c +++ /dev/null @@ -1,20 +0,0 @@ -#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 deleted file mode 100644 index c6b10d0e9c3..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dfe.c +++ /dev/null @@ -1,151 +0,0 @@ -#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 deleted file mode 100644 index 4070d879012..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dolio.c +++ /dev/null @@ -1,26 +0,0 @@ -#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 deleted file mode 100644 index 6a09b3e9837..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/dtime_.c +++ /dev/null @@ -1,63 +0,0 @@ -#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 deleted file mode 100644 index a7f4cec4673..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/due.c +++ /dev/null @@ -1,77 +0,0 @@ -#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 deleted file mode 100644 index 70be0bc2e0b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1asc_.c +++ /dev/null @@ -1,25 +0,0 @@ -/* 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 deleted file mode 100644 index 4b420ae6465..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ef1cmc_.c +++ /dev/null @@ -1,20 +0,0 @@ -/* 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 deleted file mode 100644 index 04020d3802d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/endfile.c +++ /dev/null @@ -1,160 +0,0 @@ -#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 deleted file mode 100644 index 532fec61c86..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/erf_.c +++ /dev/null @@ -1,22 +0,0 @@ -#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 deleted file mode 100644 index 6f6c9f10644..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/erfc_.c +++ /dev/null @@ -1,22 +0,0 @@ -#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 deleted file mode 100644 index b81ffc111f0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/err.c +++ /dev/null @@ -1,282 +0,0 @@ -#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 deleted file mode 100644 index 2d9a36d8a31..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/etime_.c +++ /dev/null @@ -1,57 +0,0 @@ -#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 deleted file mode 100644 index 08e9d07067c..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/exit_.c +++ /dev/null @@ -1,43 +0,0 @@ -/* 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 deleted file mode 100644 index f66d28be5d2..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h +++ /dev/null @@ -1,233 +0,0 @@ -/* 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; -#ifdef WIN32 -#define _COMPLEX_DEFINED 1 -#endif -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. */ -#if defined(WIN32) && !defined(__MINGW32__) -typedef __int64 longint; /* system-dependent */ -typedef unsigned __int64 ulongint; /* system-dependent */ -#else -typedef long long longint; /* system-dependent */ -typedef unsigned long long ulongint; /* system-dependent */ -#endif -#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) -#undef min -#undef max -#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 deleted file mode 100644 index 1ff0f896b30..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77_aloc.c +++ /dev/null @@ -1,44 +0,0 @@ -#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 deleted file mode 100644 index 782d40160ca..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f77vers.c +++ /dev/null @@ -1,93 +0,0 @@ - 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 deleted file mode 100644 index e709dde1934..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h +++ /dev/null @@ -1,149 +0,0 @@ -#ifndef SYSDEP_H_INCLUDED -#include "sysdep1.h" -#endif -#include /* for off_t */ -#include "stdio.h" -#ifdef HAVE_UNISTD_H -#include /* for isatty() */ -#endif -#ifdef WIN32 -extern int w32getc(FILE *f); -#define getc w32getc -#endif -#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 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 deleted file mode 100644 index 80bcd0a7663..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.c +++ /dev/null @@ -1,525 +0,0 @@ -#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 deleted file mode 100644 index a2fdc651778..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmt.h +++ /dev/null @@ -1,104 +0,0 @@ -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 deleted file mode 100644 index 279f66f4390..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fmtlib.c +++ /dev/null @@ -1,51 +0,0 @@ -/* @(#)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 deleted file mode 100644 index 40743d79f74..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fp.h +++ /dev/null @@ -1,28 +0,0 @@ -#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 deleted file mode 100644 index 9cc00cba8b9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell64_.c +++ /dev/null @@ -1,52 +0,0 @@ -#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 deleted file mode 100644 index be9f2871086..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ftell_.c +++ /dev/null @@ -1,52 +0,0 @@ -#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 deleted file mode 100644 index 9006ad20169..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/getarg_.c +++ /dev/null @@ -1,34 +0,0 @@ -#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 deleted file mode 100644 index db6906869cf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 443427a9b99..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 1ec641c5aa4..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_dnnt.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 018f2f43861..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_indx.c +++ /dev/null @@ -1,32 +0,0 @@ -#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 deleted file mode 100644 index 8b0aea99d26..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_len.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 611ef0aa8bf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_mod.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 9e2282f2a74..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_nint.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 4e214380cf9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/h_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 8c72f03d489..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_ge.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index a448522db4b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_gt.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 31cbc431a3f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_le.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 7ad3c714b1d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/hl_lt.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 60cc24eec19..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i77vers.c +++ /dev/null @@ -1,343 +0,0 @@ - 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 deleted file mode 100644 index 2b92c4aa782..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 60ed4d8c5b4..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 3abc2dc4a51..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_dnnt.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 19256393ecd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_indx.c +++ /dev/null @@ -1,32 +0,0 @@ -#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 deleted file mode 100644 index 0f7b188d65a..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_len.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 4a9b5609ba4..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_mod.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index fe9fd68a86e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_nint.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 4c20e9494e1..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/i_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 2f29da0eaa6..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/iargc_.c +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 index 8553efcf97f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/iio.c +++ /dev/null @@ -1,159 +0,0 @@ -#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 deleted file mode 100644 index e8b3d49cf1f..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/ilnw.c +++ /dev/null @@ -1,83 +0,0 @@ -#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 deleted file mode 100644 index 5936a674ccc..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/inquire.c +++ /dev/null @@ -1,117 +0,0 @@ -#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 deleted file mode 100644 index a84f0ee4abc..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_ge.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index ae6950d1391..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_gt.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 625b49a9ea9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_le.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index ab21b362de9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/l_lt.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 5b6ccf72d0a..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitbits.c +++ /dev/null @@ -1,68 +0,0 @@ -#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 deleted file mode 100644 index fbee94f1403..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lbitshft.c +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 index 012317206aa..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lio.h +++ /dev/null @@ -1,74 +0,0 @@ -/* 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 deleted file mode 100644 index 9636ae9c46e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lread.c +++ /dev/null @@ -1,803 +0,0 @@ -#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(); -#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 deleted file mode 100644 index 9e0d93deb50..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/lwrite.c +++ /dev/null @@ -1,314 +0,0 @@ -#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 deleted file mode 100644 index 45397490471..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/main.c +++ /dev/null @@ -1,147 +0,0 @@ -/* 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 deleted file mode 100644 index 49f739a3d7d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c +++ /dev/null @@ -1,302 +0,0 @@ -#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"}; -#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+"}; -#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 deleted file mode 100644 index 574e0b1ebac..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ci.c +++ /dev/null @@ -1,26 +0,0 @@ -#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 deleted file mode 100644 index 08fc20884ae..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_dd.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index abf36cb74c0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_di.c +++ /dev/null @@ -1,41 +0,0 @@ -#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 deleted file mode 100644 index 882168501aa..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_hh.c +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100644 index 748d1217733..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ii.c +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100644 index 09fe18ec8e7..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_qq.c +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100644 index e29d416eba2..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_ri.c +++ /dev/null @@ -1,41 +0,0 @@ -#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 deleted file mode 100644 index 1c0a4b07c2d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zi.c +++ /dev/null @@ -1,60 +0,0 @@ -#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 deleted file mode 100644 index b5ffd334835..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/pow_zz.c +++ /dev/null @@ -1,29 +0,0 @@ -#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 deleted file mode 100644 index ba1b5bd0c97..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitbits.c +++ /dev/null @@ -1,72 +0,0 @@ -#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 deleted file mode 100644 index 78e7b95100d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/qbitshft.c +++ /dev/null @@ -1,17 +0,0 @@ -#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 deleted file mode 100644 index f3291fb4d14..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 103c7ff070b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_acos.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 432b9406ac7..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_asin.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 7656982db45..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atan.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index ab957b89d54..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_atn2.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index cef0e4b092b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cnjg.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 4418f0c1bbf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cos.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index f5478355809..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_cosh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index d573ca36d8d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index 4e679794f22..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_exp.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 1b4de14373a..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_imag.c +++ /dev/null @@ -1,16 +0,0 @@ -#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 deleted file mode 100644 index bff87176ff6..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_int.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 64ffddf48b0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_lg10.c +++ /dev/null @@ -1,21 +0,0 @@ -#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 deleted file mode 100644 index 94c79b05185..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_log.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 63ed1753689..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_mod.c +++ /dev/null @@ -1,46 +0,0 @@ -#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 deleted file mode 100644 index 7cc3f1b5aea..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_nint.c +++ /dev/null @@ -1,20 +0,0 @@ -#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 deleted file mode 100644 index 797db1a4cbf..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 37e0df25fa5..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sin.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 39878f03ae7..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sinh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index e7b2c1c704a..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_sqrt.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 1774bed73a5..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tan.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index 7739c6ce846..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/r_tanh.c +++ /dev/null @@ -1,19 +0,0 @@ -#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 deleted file mode 100644 index fd36a482602..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rawio.h +++ /dev/null @@ -1,41 +0,0 @@ -#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 deleted file mode 100644 index 62b28053409..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rdfmt.c +++ /dev/null @@ -1,550 +0,0 @@ -#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 deleted file mode 100644 index 9a0e07e6cfa..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rewind.c +++ /dev/null @@ -1,30 +0,0 @@ -#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 deleted file mode 100644 index abe9724a7b8..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsfe.c +++ /dev/null @@ -1,91 +0,0 @@ -/* 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 deleted file mode 100644 index 3d4ea428fc9..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsli.c +++ /dev/null @@ -1,109 +0,0 @@ -#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 deleted file mode 100644 index 3a32c40b259..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/rsne.c +++ /dev/null @@ -1,615 +0,0 @@ -#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 -#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 deleted file mode 100644 index 5bf8a628ac0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cat.c +++ /dev/null @@ -1,86 +0,0 @@ -/* 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 deleted file mode 100644 index 3a2ea67ddf0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_cmp.c +++ /dev/null @@ -1,50 +0,0 @@ -#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 deleted file mode 100644 index 9dacfc7d8d2..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_copy.c +++ /dev/null @@ -1,57 +0,0 @@ -/* 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 deleted file mode 100644 index 51d80eb0878..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_paus.c +++ /dev/null @@ -1,96 +0,0 @@ -#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 deleted file mode 100644 index 5c12b949634..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_rnge.c +++ /dev/null @@ -1,32 +0,0 @@ -#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 deleted file mode 100644 index 68233aea7e3..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/s_stop.c +++ /dev/null @@ -1,48 +0,0 @@ -#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 deleted file mode 100644 index 8c22cd58113..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sig_die.c +++ /dev/null @@ -1,51 +0,0 @@ -#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 deleted file mode 100644 index a383774b82d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal1.h +++ /dev/null @@ -1,35 +0,0 @@ -/* 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 deleted file mode 100644 index 3b0e6cfe98b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signal_.c +++ /dev/null @@ -1,21 +0,0 @@ -#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 deleted file mode 100644 index de95a3b70fd..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/signbit.c +++ /dev/null @@ -1,24 +0,0 @@ -#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 deleted file mode 100644 index 191e32627cc..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sue.c +++ /dev/null @@ -1,90 +0,0 @@ -#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 deleted file mode 100644 index 4c026a240a1..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/sysdep1.h +++ /dev/null @@ -1,66 +0,0 @@ -#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 deleted file mode 100644 index 3220bfb5c2d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/system_.c +++ /dev/null @@ -1,42 +0,0 @@ -/* 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 deleted file mode 100644 index 39097f46991..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/typesize.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 44f768d9a24..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/uio.c +++ /dev/null @@ -1,75 +0,0 @@ -#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 deleted file mode 100644 index 794cd6adee0..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/uninit.c +++ /dev/null @@ -1,368 +0,0 @@ -#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 deleted file mode 100644 index f4b3aef2ce7..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/util.c +++ /dev/null @@ -1,54 +0,0 @@ -#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 deleted file mode 100644 index a970db95910..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c +++ /dev/null @@ -1,377 +0,0 @@ -#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 deleted file mode 100644 index 8709f3b3479..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsfe.c +++ /dev/null @@ -1,78 +0,0 @@ -/*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 deleted file mode 100644 index 3e602702c0c..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsle.c +++ /dev/null @@ -1,42 +0,0 @@ -#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 deleted file mode 100644 index e204a51a4f1..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wsne.c +++ /dev/null @@ -1,32 +0,0 @@ -#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 deleted file mode 100644 index f810d3edbfe..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/xwsne.c +++ /dev/null @@ -1,77 +0,0 @@ -#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 deleted file mode 100644 index 4d8a015d384..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#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 deleted file mode 100644 index 4abe8bf8820..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_cos.c +++ /dev/null @@ -1,21 +0,0 @@ -#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 deleted file mode 100644 index b61f03b8efc..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_div.c +++ /dev/null @@ -1,50 +0,0 @@ -#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 deleted file mode 100644 index 7b8edfece03..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_exp.c +++ /dev/null @@ -1,23 +0,0 @@ -#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 deleted file mode 100644 index 4f11bbe0c78..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_log.c +++ /dev/null @@ -1,121 +0,0 @@ -#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 deleted file mode 100644 index 01225a9448d..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sin.c +++ /dev/null @@ -1,21 +0,0 @@ -#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 deleted file mode 100644 index 35bd44c8e08..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/z_sqrt.c +++ /dev/null @@ -1,35 +0,0 @@ -#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 deleted file mode 100755 index 4c9860e66ae..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/pmx.test +++ /dev/null @@ -1,26 +0,0 @@ -#! /bin/sh - -# Copyright (C) 2012 Peter Breitenlohner -# You may freely use, modify and/or distribute this file. - -rm -f barsant* pmxaerr.dat - -cp $test_src/barsant.pmx . - -failed= - -./scor2prt barsant \ - && diff barsant1.pmx $test_src/barsant1.pmx \ - && diff barsant2.pmx $test_src/barsant2.pmx \ - || failed="$failed scor2prt" - -./pmxab barsant \ - && diff barsant.mid $test_src/barsant.mid \ - && diff barsant.pml $test_src/barsant.pml \ - && diff barsant.tex $test_src/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/pmx2618.for b/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for deleted file mode 100644 index e5f73564979..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for +++ /dev/null @@ -1,23646 +0,0 @@ - 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 deleted file mode 100644 index f310e70a83c..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/pmx2618.for.orig +++ /dev/null @@ -1,23646 +0,0 @@ - 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 deleted file mode 100644 index 2f75b2d534a..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/pmxab.c +++ /dev/null @@ -1,37988 +0,0 @@ -/* -- 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 deleted file mode 100644 index 9dd04f65961..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.c +++ /dev/null @@ -1,2775 +0,0 @@ -/* -- 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.for b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for deleted file mode 100644 index 99fe18e4cab..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for +++ /dev/null @@ -1,1620 +0,0 @@ -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 deleted file mode 100644 index b785cad009b..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for.orig +++ /dev/null @@ -1,1619 +0,0 @@ -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 deleted file mode 100644 index ccd7219e2be..00000000000 Binary files a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.mid and /dev/null 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 deleted file mode 100644 index 0c514716522..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pml +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index f10fd67b064..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.pmx +++ /dev/null @@ -1,68 +0,0 @@ -%----------------% -% -% 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 deleted file mode 100644 index fe003c3404e..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant.tex +++ /dev/null @@ -1,307 +0,0 @@ -%%%%%%%%%%%%%%%%% -% -% 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 deleted file mode 100644 index 2aea3d406eb..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant1.pmx +++ /dev/null @@ -1,48 +0,0 @@ -%----------------% -% -% 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 deleted file mode 100644 index a21386f4768..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/tests/barsant2.pmx +++ /dev/null @@ -1,66 +0,0 @@ -%----------------% -% -% 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 deleted file mode 100644 index cdb0e0b0dbe..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/version.ac +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 index 32f9d625953..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.18/w32getc.c +++ /dev/null @@ -1,14 +0,0 @@ -#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/pmx-2.6.19-PATCHES/TL-Changes b/Build/source/utils/pmx/pmx-2.6.19-PATCHES/TL-Changes index 765324edd11..4d67332eb5c 100644 --- a/Build/source/utils/pmx/pmx-2.6.19-PATCHES/TL-Changes +++ b/Build/source/utils/pmx/pmx-2.6.19-PATCHES/TL-Changes @@ -4,6 +4,7 @@ Changes applied to the pmx-2.6.19 tree as obtained from: Remove: Makefile.in aclocal.m4 + arith.h configure depcomp install-sh -- cgit v1.2.3