summaryrefslogtreecommitdiff
path: root/Build/source/utils/pmx
diff options
context:
space:
mode:
authorPeter Breitenlohner <peb@mppmu.mpg.de>2012-05-20 10:47:27 +0000
committerPeter Breitenlohner <peb@mppmu.mpg.de>2012-05-20 10:47:27 +0000
commit4a0b3e0795ff26c3ad05eebcd302499751a85533 (patch)
treeae21b2d7e0f1b5cb5577cd26d9013f14ca630e22 /Build/source/utils/pmx
parent2ca45d9d72fa0af0158e732449d29281505da678 (diff)
more pmx 2.6.18
do handle pmx2pdf.lua here because we need a symlink in bindir git-svn-id: svn://tug.org/texlive/trunk@26502 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/utils/pmx')
-rw-r--r--Build/source/utils/pmx/ChangeLog16
-rw-r--r--Build/source/utils/pmx/Makefile.am22
-rw-r--r--Build/source/utils/pmx/Makefile.in382
-rw-r--r--Build/source/utils/pmx/README4
-rw-r--r--Build/source/utils/pmx/arith.h3
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/ChangeLog19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-01-binary17
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-02-bugfix19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-03-DOS-line-endings18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-04-MSVC-complex18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-05-FreeBSD-off_t13
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/AUTHORS1
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/COPYING622
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/ChangeLog200
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/INSTALL365
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/Makefile.am8
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/NEWS46
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/README11
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/config.h.in90
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/configure.ac37
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/Makefile61
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/Notice23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/README329
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/abort_.c22
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/arithchk.c225
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/backspac.c76
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_abs.c20
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_cos.c23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_div.c53
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_exp.c25
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_log.c23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_sin.c23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/c_sqrt.c41
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/cabs.c33
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/close.c101
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_abs.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_acos.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_asin.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_atan.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_atn2.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cnjg.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cos.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cosh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_dim.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_exp.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_imag.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_int.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_lg10.c21
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_log.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_mod.c46
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_nint.c20
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_prod.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sign.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sin.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sinh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sqrt.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_tan.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/d_tanh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/derf_.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/derfc_.c20
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/dfe.c151
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/dolio.c26
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/dtime_.c63
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/due.c77
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/ef1asc_.c25
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/ef1cmc_.c20
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/endfile.c160
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/erf_.c22
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/erfc_.c22
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/err.c282
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/etime_.c57
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/exit_.c43
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/f2c.h226
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/f77_aloc.c44
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/f77vers.c93
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/fio.h147
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/fmt.c525
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/fmt.h104
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/fmtlib.c51
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/fp.h28
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/ftell64_.c52
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/ftell_.c52
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/getarg_.c34
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/getenv_.c62
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_abs.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_dim.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_dnnt.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_indx.c32
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_len.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_mod.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_nint.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/h_sign.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_ge.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_gt.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_le.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_lt.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i77vers.c343
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_abs.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_dim.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_dnnt.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_indx.c32
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_len.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_mod.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_nint.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/i_sign.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/iargc_.c17
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/iio.c159
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/ilnw.c83
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/inquire.c117
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/l_ge.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/l_gt.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/l_le.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/l_lt.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/lbitbits.c68
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/lbitshft.c17
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/lio.h74
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/lread.c805
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/lwrite.c314
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/main.c147
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/open.c302
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ci.c26
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_dd.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_di.c41
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_hh.c39
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ii.c39
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_qq.c39
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ri.c41
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_zi.c60
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_zz.c29
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/qbitbits.c72
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/qbitshft.c17
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_abs.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_acos.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_asin.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_atan.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_atn2.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cnjg.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cos.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cosh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_dim.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_exp.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_imag.c16
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_int.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_lg10.c21
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_log.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_mod.c46
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_nint.c20
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sign.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sin.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sinh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sqrt.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_tan.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/r_tanh.c19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rawio.h41
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rdfmt.c550
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rewind.c30
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rsfe.c91
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rsli.c109
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/rsne.c616
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_cat.c86
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_cmp.c50
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_copy.c57
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_paus.c96
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_rnge.c32
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/s_stop.c48
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/sfe.c43
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/sig_die.c51
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/signal1.h35
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/signal_.c21
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/signbit.c24
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/sue.c90
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/sysdep1.h66
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/system_.c42
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/typesize.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/uio.c75
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/uninit.c368
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/util.c54
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/wref.c294
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/wrtfmt.c377
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/wsfe.c78
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/wsle.c42
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/wsne.c32
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/xwsne.c77
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_abs.c18
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_cos.c21
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_div.c50
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_exp.c23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_log.c121
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_sin.c21
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/libf2c/z_sqrt.c35
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/pmx2617.f23597
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/pmxab.c37856
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/scor2prt.c2783
-rw-r--r--Build/source/utils/pmx/pmx-2.6.17/scor2prt.f1619
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog8
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes4
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary6
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix19
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings6
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-04-MSVC-complex6
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-05-FreeBSD-off_t6
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/arith.h0
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/config.h.in90
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile61
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice23
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/README329
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c225
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h3
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h5
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c3
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/pmx2617.f23597
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/scor2prt.f1619
-rwxr-xr-xBuild/source/utils/pmx/pmx.test12
-rw-r--r--Build/source/utils/pmx/pmx2pdf.1 (renamed from Build/source/utils/pmx/pmx.1)6
-rwxr-xr-xBuild/source/utils/pmx/pmx2pdf.lua (renamed from Build/source/utils/pmx/pmx.lua)16
-rw-r--r--Build/source/utils/pmx/tests/barsant.midbin3077 -> 0 bytes
-rw-r--r--Build/source/utils/pmx/tests/barsant.pml24
-rw-r--r--Build/source/utils/pmx/tests/barsant.pmx68
-rw-r--r--Build/source/utils/pmx/tests/barsant.tex307
-rw-r--r--Build/source/utils/pmx/tests/barsant1.pmx48
-rw-r--r--Build/source/utils/pmx/tests/barsant2.pmx66
-rw-r--r--Build/source/utils/pmx/w32getc.c14
223 files changed, 350 insertions, 105582 deletions
diff --git a/Build/source/utils/pmx/ChangeLog b/Build/source/utils/pmx/ChangeLog
index bc205644dfb..e0102b69495 100644
--- a/Build/source/utils/pmx/ChangeLog
+++ b/Build/source/utils/pmx/ChangeLog
@@ -1,3 +1,9 @@
+2012-05-20 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ * Makefile.am: do handle pmx2pdf.lua here, since although it is
+ distributed as part of the texmf.zip we must create a symlink
+ in bindir.
+
2012-05-20 Karl Berry <karl@tug.org>
* Makefile.am: do not handle pmx2pdf.lua here, since
@@ -5,8 +11,14 @@
sources.
2012-05-18 Karl Berry <karl@tug.org>
-
- * pmx-2.6.18.
+ and Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ Import pmx-2.6.18.
+ * w32getc.c, tests/ (removed): Now distributed from upstream.
+ * arith.h (removed): Unused.
+ * pmx.lua, pmx.1 (removed): Renamed ...
+ * pmx2pdf.lua, pmx2pdf.1 (new): ... into these and updated.
+ * Makefile.am, pmx.test, version.ac: Adapted.
2012-04-01 Peter Breitenlohner <peb@mppmu.mpg.de>
diff --git a/Build/source/utils/pmx/Makefile.am b/Build/source/utils/pmx/Makefile.am
index 17cef19b860..1cb9cef6c64 100644
--- a/Build/source/utils/pmx/Makefile.am
+++ b/Build/source/utils/pmx/Makefile.am
@@ -29,7 +29,6 @@ noinst_LIBRARIES = libf2c.a
## libf2c headers
libf2c_a_SOURCES = \
- arith.h \
$(PMX_TREE)/libf2c/f2c.h \
$(PMX_TREE)/libf2c/fio.h \
$(PMX_TREE)/libf2c/fmt.h \
@@ -222,7 +221,8 @@ libf2c_a_SOURCES += \
## Handle DOS line endings
if WIN32
-libf2c_a_SOURCES += w32getc.c
+libf2c_a_SOURCES += \
+ $(PMX_TREE)/w32getc.c
endif WIN32
## QINT (unused)
@@ -235,6 +235,20 @@ EXTRA_libf2c_a_SOURCES += \
EXTRA_libf2c_a_SOURCES += \
$(PMX_TREE)/libf2c/signbit.c
+lua_scripts = pmx2pdf
+
+scriptsdir = texmf-dist/scripts/pmx
+nodist_bin_SCRIPTS =
+
+include $(srcdir)/../../texk/am/script_links.am
+
+texmfdir = $(datarootdir)/$(scriptsdir)
+dist_texmf_SCRIPTS = $(lua_scripts:=.lua)
+
+install-data-hook: install-lua-links
+
+uninstall-hook: uninstall-links
+
dist_man1_MANS = pmx2pdf.1 pmxab.1 scor2prt.1
## Tests
@@ -242,8 +256,8 @@ dist_man1_MANS = pmx2pdf.1 pmxab.1 scor2prt.1
TESTS = pmx.test
EXTRA_DIST += $(TESTS)
+TESTS_ENVIRONMENT = test_src=$(srcdir)/$(PMX_TREE)/tests
+
## pmx.test
-EXTRA_DIST += tests/barsant.mid tests/barsant.pml tests/barsant.pmx \
- tests/barsant.tex tests/barsant1.pmx tests/barsant2.pmx
DISTCLEANFILES = barsant* pmxaerr.dat
diff --git a/Build/source/utils/pmx/Makefile.in b/Build/source/utils/pmx/Makefile.in
index 55dce6533f0..283b5ad77ff 100644
--- a/Build/source/utils/pmx/Makefile.in
+++ b/Build/source/utils/pmx/Makefile.in
@@ -16,6 +16,7 @@
@SET_MAKE@
+
VPATH = @srcdir@
am__make_dryrun = \
{ \
@@ -51,9 +52,11 @@ NORMAL_UNINSTALL = :
PRE_UNINSTALL = :
POST_UNINSTALL = :
bin_PROGRAMS = pmxab$(EXEEXT) scor2prt$(EXEEXT)
-@WIN32_TRUE@am__append_1 = w32getc.c
-subdir = .
+@WIN32_TRUE@am__append_1 = \
+@WIN32_TRUE@ $(PMX_TREE)/w32getc.c
+
DIST_COMMON = README $(am__configure_deps) $(dist_man1_MANS) \
+ $(dist_texmf_SCRIPTS) $(srcdir)/../../texk/am/script_links.am \
$(srcdir)/Makefile.am $(srcdir)/Makefile.in \
$(top_srcdir)/../../build-aux/depcomp \
$(top_srcdir)/../../build-aux/install-sh \
@@ -62,6 +65,8 @@ DIST_COMMON = README $(am__configure_deps) $(dist_man1_MANS) \
../../build-aux/depcomp ../../build-aux/install-sh \
../../build-aux/ltmain.sh ../../build-aux/missing \
../../build-aux/texinfo.tex ../../build-aux/ylwrap ChangeLog
+@WIN32_TRUE@@WIN32_WRAP_TRUE@am__append_2 = $(wrappers)
+subdir = .
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
am__aclocal_m4_deps = $(top_srcdir)/../../m4/kpse-warnings.m4 \
$(top_srcdir)/../../m4/kpse-win32.m4 $(top_srcdir)/version.ac \
@@ -78,7 +83,7 @@ AR = ar
ARFLAGS = cru
libf2c_a_AR = $(AR) $(ARFLAGS)
libf2c_a_LIBADD =
-am__libf2c_a_SOURCES_DIST = arith.h $(PMX_TREE)/libf2c/f2c.h \
+am__libf2c_a_SOURCES_DIST = $(PMX_TREE)/libf2c/f2c.h \
$(PMX_TREE)/libf2c/fio.h $(PMX_TREE)/libf2c/fmt.h \
$(PMX_TREE)/libf2c/fp.h $(PMX_TREE)/libf2c/lio.h \
$(PMX_TREE)/libf2c/rawio.h $(PMX_TREE)/libf2c/signal1.h \
@@ -158,7 +163,7 @@ am__libf2c_a_SOURCES_DIST = arith.h $(PMX_TREE)/libf2c/f2c.h \
$(PMX_TREE)/libf2c/wrtfmt.c $(PMX_TREE)/libf2c/wsfe.c \
$(PMX_TREE)/libf2c/wsle.c $(PMX_TREE)/libf2c/wsne.c \
$(PMX_TREE)/libf2c/xwsne.c $(PMX_TREE)/libf2c/dtime_.c \
- $(PMX_TREE)/libf2c/etime_.c w32getc.c
+ $(PMX_TREE)/libf2c/etime_.c $(PMX_TREE)/w32getc.c
@WIN32_TRUE@am__objects_1 = w32getc.$(OBJEXT)
am_libf2c_a_OBJECTS = abort_.$(OBJEXT) cabs.$(OBJEXT) derf_.$(OBJEXT) \
derfc_.$(OBJEXT) erf_.$(OBJEXT) erfc_.$(OBJEXT) \
@@ -210,7 +215,8 @@ am_libf2c_a_OBJECTS = abort_.$(OBJEXT) cabs.$(OBJEXT) derf_.$(OBJEXT) \
xwsne.$(OBJEXT) dtime_.$(OBJEXT) etime_.$(OBJEXT) \
$(am__objects_1)
libf2c_a_OBJECTS = $(am_libf2c_a_OBJECTS)
-am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)"
+am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(texmfdir)" \
+ "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)"
PROGRAMS = $(bin_PROGRAMS)
am_pmxab_OBJECTS = pmxab.$(OBJEXT)
pmxab_OBJECTS = $(am_pmxab_OBJECTS)
@@ -220,23 +226,6 @@ am_scor2prt_OBJECTS = scor2prt.$(OBJEXT)
scor2prt_OBJECTS = $(am_scor2prt_OBJECTS)
scor2prt_LDADD = $(LDADD)
scor2prt_DEPENDENCIES = libf2c.a
-DEFAULT_INCLUDES = -I.@am__isrc@
-depcomp = $(SHELL) $(top_srcdir)/../../build-aux/depcomp
-am__depfiles_maybe = depfiles
-am__mv = mv -f
-COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
- $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
-CCLD = $(CC)
-LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@
-SOURCES = $(libf2c_a_SOURCES) $(EXTRA_libf2c_a_SOURCES) \
- $(pmxab_SOURCES) $(scor2prt_SOURCES)
-DIST_SOURCES = $(am__libf2c_a_SOURCES_DIST) $(EXTRA_libf2c_a_SOURCES) \
- $(pmxab_SOURCES) $(scor2prt_SOURCES)
-am__can_run_installinfo = \
- case $$AM_UPDATE_INFO_DIR in \
- n|no|NO) false;; \
- *) (install-info --version) >/dev/null 2>&1;; \
- esac
am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
am__vpath_adj = case $$p in \
$(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
@@ -264,6 +253,24 @@ am__uninstall_files_from_dir = { \
|| { echo " ( cd '$$dir' && rm -f" $$files ")"; \
$(am__cd) "$$dir" && rm -f $$files; }; \
}
+SCRIPTS = $(dist_texmf_SCRIPTS) $(nodist_bin_SCRIPTS)
+DEFAULT_INCLUDES = -I.@am__isrc@
+depcomp = $(SHELL) $(top_srcdir)/../../build-aux/depcomp
+am__depfiles_maybe = depfiles
+am__mv = mv -f
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+CCLD = $(CC)
+LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@
+SOURCES = $(libf2c_a_SOURCES) $(EXTRA_libf2c_a_SOURCES) \
+ $(pmxab_SOURCES) $(scor2prt_SOURCES)
+DIST_SOURCES = $(am__libf2c_a_SOURCES_DIST) $(EXTRA_libf2c_a_SOURCES) \
+ $(pmxab_SOURCES) $(scor2prt_SOURCES)
+am__can_run_installinfo = \
+ case $$AM_UPDATE_INFO_DIR in \
+ n|no|NO) false;; \
+ *) (install-info --version) >/dev/null 2>&1;; \
+ esac
man1dir = $(mandir)/man1
NROFF = nroff
MANS = $(dist_man1_MANS)
@@ -385,102 +392,110 @@ top_build_prefix = @top_build_prefix@
top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
ACLOCAL_AMFLAGS = -I ../../m4
-EXTRA_DIST = $(PMX_TREE) $(PMX_TREE)-PATCHES $(TESTS) \
- tests/barsant.mid tests/barsant.pml tests/barsant.pmx \
- tests/barsant.tex tests/barsant1.pmx tests/barsant2.pmx
+EXTRA_DIST = $(PMX_TREE) $(PMX_TREE)-PATCHES ../../build-aux/relpath \
+ $(TESTS)
INCLUDES = -I$(srcdir)/$(PMX_TREE)/libf2c
AM_CFLAGS = #$(WARNING_CFLAGS)
pmxab_SOURCES = $(PMX_TREE)/pmxab.c
scor2prt_SOURCES = $(PMX_TREE)/scor2prt.c
LDADD = libf2c.a
noinst_LIBRARIES = libf2c.a
-libf2c_a_SOURCES = arith.h $(PMX_TREE)/libf2c/f2c.h \
- $(PMX_TREE)/libf2c/fio.h $(PMX_TREE)/libf2c/fmt.h \
- $(PMX_TREE)/libf2c/fp.h $(PMX_TREE)/libf2c/lio.h \
- $(PMX_TREE)/libf2c/rawio.h $(PMX_TREE)/libf2c/signal1.h \
- $(PMX_TREE)/libf2c/sysdep1.h $(PMX_TREE)/libf2c/abort_.c \
- $(PMX_TREE)/libf2c/cabs.c $(PMX_TREE)/libf2c/derf_.c \
- $(PMX_TREE)/libf2c/derfc_.c $(PMX_TREE)/libf2c/erf_.c \
- $(PMX_TREE)/libf2c/erfc_.c $(PMX_TREE)/libf2c/exit_.c \
- $(PMX_TREE)/libf2c/f77vers.c $(PMX_TREE)/libf2c/getarg_.c \
- $(PMX_TREE)/libf2c/getenv_.c $(PMX_TREE)/libf2c/i77vers.c \
- $(PMX_TREE)/libf2c/iargc_.c $(PMX_TREE)/libf2c/main.c \
- $(PMX_TREE)/libf2c/s_paus.c $(PMX_TREE)/libf2c/s_rnge.c \
- $(PMX_TREE)/libf2c/s_stop.c $(PMX_TREE)/libf2c/sig_die.c \
- $(PMX_TREE)/libf2c/signal_.c $(PMX_TREE)/libf2c/system_.c \
- $(PMX_TREE)/libf2c/pow_ci.c $(PMX_TREE)/libf2c/pow_dd.c \
- $(PMX_TREE)/libf2c/pow_di.c $(PMX_TREE)/libf2c/pow_hh.c \
- $(PMX_TREE)/libf2c/pow_ii.c $(PMX_TREE)/libf2c/pow_ri.c \
- $(PMX_TREE)/libf2c/pow_zi.c $(PMX_TREE)/libf2c/pow_zz.c \
- $(PMX_TREE)/libf2c/c_abs.c $(PMX_TREE)/libf2c/c_cos.c \
- $(PMX_TREE)/libf2c/c_div.c $(PMX_TREE)/libf2c/c_exp.c \
- $(PMX_TREE)/libf2c/c_log.c $(PMX_TREE)/libf2c/c_sin.c \
- $(PMX_TREE)/libf2c/c_sqrt.c $(PMX_TREE)/libf2c/z_abs.c \
- $(PMX_TREE)/libf2c/z_cos.c $(PMX_TREE)/libf2c/z_div.c \
- $(PMX_TREE)/libf2c/z_exp.c $(PMX_TREE)/libf2c/z_log.c \
- $(PMX_TREE)/libf2c/z_sin.c $(PMX_TREE)/libf2c/z_sqrt.c \
- $(PMX_TREE)/libf2c/r_abs.c $(PMX_TREE)/libf2c/r_acos.c \
- $(PMX_TREE)/libf2c/r_asin.c $(PMX_TREE)/libf2c/r_atan.c \
- $(PMX_TREE)/libf2c/r_atn2.c $(PMX_TREE)/libf2c/r_cnjg.c \
- $(PMX_TREE)/libf2c/r_cos.c $(PMX_TREE)/libf2c/r_cosh.c \
- $(PMX_TREE)/libf2c/r_dim.c $(PMX_TREE)/libf2c/r_exp.c \
- $(PMX_TREE)/libf2c/r_imag.c $(PMX_TREE)/libf2c/r_int.c \
- $(PMX_TREE)/libf2c/r_lg10.c $(PMX_TREE)/libf2c/r_log.c \
- $(PMX_TREE)/libf2c/r_mod.c $(PMX_TREE)/libf2c/r_nint.c \
- $(PMX_TREE)/libf2c/r_sign.c $(PMX_TREE)/libf2c/r_sin.c \
- $(PMX_TREE)/libf2c/r_sinh.c $(PMX_TREE)/libf2c/r_sqrt.c \
- $(PMX_TREE)/libf2c/r_tan.c $(PMX_TREE)/libf2c/r_tanh.c \
- $(PMX_TREE)/libf2c/d_abs.c $(PMX_TREE)/libf2c/d_acos.c \
- $(PMX_TREE)/libf2c/d_asin.c $(PMX_TREE)/libf2c/d_atan.c \
- $(PMX_TREE)/libf2c/d_atn2.c $(PMX_TREE)/libf2c/d_cnjg.c \
- $(PMX_TREE)/libf2c/d_cos.c $(PMX_TREE)/libf2c/d_cosh.c \
- $(PMX_TREE)/libf2c/d_dim.c $(PMX_TREE)/libf2c/d_exp.c \
- $(PMX_TREE)/libf2c/d_imag.c $(PMX_TREE)/libf2c/d_int.c \
- $(PMX_TREE)/libf2c/d_lg10.c $(PMX_TREE)/libf2c/d_log.c \
- $(PMX_TREE)/libf2c/d_mod.c $(PMX_TREE)/libf2c/d_nint.c \
- $(PMX_TREE)/libf2c/d_prod.c $(PMX_TREE)/libf2c/d_sign.c \
- $(PMX_TREE)/libf2c/d_sin.c $(PMX_TREE)/libf2c/d_sinh.c \
- $(PMX_TREE)/libf2c/d_sqrt.c $(PMX_TREE)/libf2c/d_tan.c \
- $(PMX_TREE)/libf2c/d_tanh.c $(PMX_TREE)/libf2c/i_abs.c \
- $(PMX_TREE)/libf2c/i_dim.c $(PMX_TREE)/libf2c/i_dnnt.c \
- $(PMX_TREE)/libf2c/i_indx.c $(PMX_TREE)/libf2c/i_len.c \
- $(PMX_TREE)/libf2c/i_mod.c $(PMX_TREE)/libf2c/i_nint.c \
- $(PMX_TREE)/libf2c/i_sign.c $(PMX_TREE)/libf2c/lbitbits.c \
- $(PMX_TREE)/libf2c/lbitshft.c $(PMX_TREE)/libf2c/h_abs.c \
- $(PMX_TREE)/libf2c/h_dim.c $(PMX_TREE)/libf2c/h_dnnt.c \
- $(PMX_TREE)/libf2c/h_indx.c $(PMX_TREE)/libf2c/h_len.c \
- $(PMX_TREE)/libf2c/h_mod.c $(PMX_TREE)/libf2c/h_nint.c \
- $(PMX_TREE)/libf2c/h_sign.c $(PMX_TREE)/libf2c/hl_ge.c \
- $(PMX_TREE)/libf2c/hl_gt.c $(PMX_TREE)/libf2c/hl_le.c \
- $(PMX_TREE)/libf2c/hl_lt.c $(PMX_TREE)/libf2c/l_ge.c \
- $(PMX_TREE)/libf2c/l_gt.c $(PMX_TREE)/libf2c/l_le.c \
- $(PMX_TREE)/libf2c/l_lt.c $(PMX_TREE)/libf2c/ef1asc_.c \
- $(PMX_TREE)/libf2c/ef1cmc_.c $(PMX_TREE)/libf2c/f77_aloc.c \
- $(PMX_TREE)/libf2c/s_cat.c $(PMX_TREE)/libf2c/s_cmp.c \
- $(PMX_TREE)/libf2c/s_copy.c $(PMX_TREE)/libf2c/backspac.c \
- $(PMX_TREE)/libf2c/close.c $(PMX_TREE)/libf2c/dfe.c \
- $(PMX_TREE)/libf2c/dolio.c $(PMX_TREE)/libf2c/due.c \
- $(PMX_TREE)/libf2c/endfile.c $(PMX_TREE)/libf2c/err.c \
- $(PMX_TREE)/libf2c/fmt.c $(PMX_TREE)/libf2c/fmtlib.c \
- $(PMX_TREE)/libf2c/ftell_.c $(PMX_TREE)/libf2c/iio.c \
- $(PMX_TREE)/libf2c/ilnw.c $(PMX_TREE)/libf2c/inquire.c \
- $(PMX_TREE)/libf2c/lread.c $(PMX_TREE)/libf2c/lwrite.c \
- $(PMX_TREE)/libf2c/open.c $(PMX_TREE)/libf2c/rdfmt.c \
- $(PMX_TREE)/libf2c/rewind.c $(PMX_TREE)/libf2c/rsfe.c \
- $(PMX_TREE)/libf2c/rsli.c $(PMX_TREE)/libf2c/rsne.c \
- $(PMX_TREE)/libf2c/sfe.c $(PMX_TREE)/libf2c/sue.c \
- $(PMX_TREE)/libf2c/typesize.c $(PMX_TREE)/libf2c/uio.c \
- $(PMX_TREE)/libf2c/util.c $(PMX_TREE)/libf2c/wref.c \
- $(PMX_TREE)/libf2c/wrtfmt.c $(PMX_TREE)/libf2c/wsfe.c \
- $(PMX_TREE)/libf2c/wsle.c $(PMX_TREE)/libf2c/wsne.c \
- $(PMX_TREE)/libf2c/xwsne.c $(PMX_TREE)/libf2c/dtime_.c \
- $(PMX_TREE)/libf2c/etime_.c $(am__append_1)
+libf2c_a_SOURCES = $(PMX_TREE)/libf2c/f2c.h $(PMX_TREE)/libf2c/fio.h \
+ $(PMX_TREE)/libf2c/fmt.h $(PMX_TREE)/libf2c/fp.h \
+ $(PMX_TREE)/libf2c/lio.h $(PMX_TREE)/libf2c/rawio.h \
+ $(PMX_TREE)/libf2c/signal1.h $(PMX_TREE)/libf2c/sysdep1.h \
+ $(PMX_TREE)/libf2c/abort_.c $(PMX_TREE)/libf2c/cabs.c \
+ $(PMX_TREE)/libf2c/derf_.c $(PMX_TREE)/libf2c/derfc_.c \
+ $(PMX_TREE)/libf2c/erf_.c $(PMX_TREE)/libf2c/erfc_.c \
+ $(PMX_TREE)/libf2c/exit_.c $(PMX_TREE)/libf2c/f77vers.c \
+ $(PMX_TREE)/libf2c/getarg_.c $(PMX_TREE)/libf2c/getenv_.c \
+ $(PMX_TREE)/libf2c/i77vers.c $(PMX_TREE)/libf2c/iargc_.c \
+ $(PMX_TREE)/libf2c/main.c $(PMX_TREE)/libf2c/s_paus.c \
+ $(PMX_TREE)/libf2c/s_rnge.c $(PMX_TREE)/libf2c/s_stop.c \
+ $(PMX_TREE)/libf2c/sig_die.c $(PMX_TREE)/libf2c/signal_.c \
+ $(PMX_TREE)/libf2c/system_.c $(PMX_TREE)/libf2c/pow_ci.c \
+ $(PMX_TREE)/libf2c/pow_dd.c $(PMX_TREE)/libf2c/pow_di.c \
+ $(PMX_TREE)/libf2c/pow_hh.c $(PMX_TREE)/libf2c/pow_ii.c \
+ $(PMX_TREE)/libf2c/pow_ri.c $(PMX_TREE)/libf2c/pow_zi.c \
+ $(PMX_TREE)/libf2c/pow_zz.c $(PMX_TREE)/libf2c/c_abs.c \
+ $(PMX_TREE)/libf2c/c_cos.c $(PMX_TREE)/libf2c/c_div.c \
+ $(PMX_TREE)/libf2c/c_exp.c $(PMX_TREE)/libf2c/c_log.c \
+ $(PMX_TREE)/libf2c/c_sin.c $(PMX_TREE)/libf2c/c_sqrt.c \
+ $(PMX_TREE)/libf2c/z_abs.c $(PMX_TREE)/libf2c/z_cos.c \
+ $(PMX_TREE)/libf2c/z_div.c $(PMX_TREE)/libf2c/z_exp.c \
+ $(PMX_TREE)/libf2c/z_log.c $(PMX_TREE)/libf2c/z_sin.c \
+ $(PMX_TREE)/libf2c/z_sqrt.c $(PMX_TREE)/libf2c/r_abs.c \
+ $(PMX_TREE)/libf2c/r_acos.c $(PMX_TREE)/libf2c/r_asin.c \
+ $(PMX_TREE)/libf2c/r_atan.c $(PMX_TREE)/libf2c/r_atn2.c \
+ $(PMX_TREE)/libf2c/r_cnjg.c $(PMX_TREE)/libf2c/r_cos.c \
+ $(PMX_TREE)/libf2c/r_cosh.c $(PMX_TREE)/libf2c/r_dim.c \
+ $(PMX_TREE)/libf2c/r_exp.c $(PMX_TREE)/libf2c/r_imag.c \
+ $(PMX_TREE)/libf2c/r_int.c $(PMX_TREE)/libf2c/r_lg10.c \
+ $(PMX_TREE)/libf2c/r_log.c $(PMX_TREE)/libf2c/r_mod.c \
+ $(PMX_TREE)/libf2c/r_nint.c $(PMX_TREE)/libf2c/r_sign.c \
+ $(PMX_TREE)/libf2c/r_sin.c $(PMX_TREE)/libf2c/r_sinh.c \
+ $(PMX_TREE)/libf2c/r_sqrt.c $(PMX_TREE)/libf2c/r_tan.c \
+ $(PMX_TREE)/libf2c/r_tanh.c $(PMX_TREE)/libf2c/d_abs.c \
+ $(PMX_TREE)/libf2c/d_acos.c $(PMX_TREE)/libf2c/d_asin.c \
+ $(PMX_TREE)/libf2c/d_atan.c $(PMX_TREE)/libf2c/d_atn2.c \
+ $(PMX_TREE)/libf2c/d_cnjg.c $(PMX_TREE)/libf2c/d_cos.c \
+ $(PMX_TREE)/libf2c/d_cosh.c $(PMX_TREE)/libf2c/d_dim.c \
+ $(PMX_TREE)/libf2c/d_exp.c $(PMX_TREE)/libf2c/d_imag.c \
+ $(PMX_TREE)/libf2c/d_int.c $(PMX_TREE)/libf2c/d_lg10.c \
+ $(PMX_TREE)/libf2c/d_log.c $(PMX_TREE)/libf2c/d_mod.c \
+ $(PMX_TREE)/libf2c/d_nint.c $(PMX_TREE)/libf2c/d_prod.c \
+ $(PMX_TREE)/libf2c/d_sign.c $(PMX_TREE)/libf2c/d_sin.c \
+ $(PMX_TREE)/libf2c/d_sinh.c $(PMX_TREE)/libf2c/d_sqrt.c \
+ $(PMX_TREE)/libf2c/d_tan.c $(PMX_TREE)/libf2c/d_tanh.c \
+ $(PMX_TREE)/libf2c/i_abs.c $(PMX_TREE)/libf2c/i_dim.c \
+ $(PMX_TREE)/libf2c/i_dnnt.c $(PMX_TREE)/libf2c/i_indx.c \
+ $(PMX_TREE)/libf2c/i_len.c $(PMX_TREE)/libf2c/i_mod.c \
+ $(PMX_TREE)/libf2c/i_nint.c $(PMX_TREE)/libf2c/i_sign.c \
+ $(PMX_TREE)/libf2c/lbitbits.c $(PMX_TREE)/libf2c/lbitshft.c \
+ $(PMX_TREE)/libf2c/h_abs.c $(PMX_TREE)/libf2c/h_dim.c \
+ $(PMX_TREE)/libf2c/h_dnnt.c $(PMX_TREE)/libf2c/h_indx.c \
+ $(PMX_TREE)/libf2c/h_len.c $(PMX_TREE)/libf2c/h_mod.c \
+ $(PMX_TREE)/libf2c/h_nint.c $(PMX_TREE)/libf2c/h_sign.c \
+ $(PMX_TREE)/libf2c/hl_ge.c $(PMX_TREE)/libf2c/hl_gt.c \
+ $(PMX_TREE)/libf2c/hl_le.c $(PMX_TREE)/libf2c/hl_lt.c \
+ $(PMX_TREE)/libf2c/l_ge.c $(PMX_TREE)/libf2c/l_gt.c \
+ $(PMX_TREE)/libf2c/l_le.c $(PMX_TREE)/libf2c/l_lt.c \
+ $(PMX_TREE)/libf2c/ef1asc_.c $(PMX_TREE)/libf2c/ef1cmc_.c \
+ $(PMX_TREE)/libf2c/f77_aloc.c $(PMX_TREE)/libf2c/s_cat.c \
+ $(PMX_TREE)/libf2c/s_cmp.c $(PMX_TREE)/libf2c/s_copy.c \
+ $(PMX_TREE)/libf2c/backspac.c $(PMX_TREE)/libf2c/close.c \
+ $(PMX_TREE)/libf2c/dfe.c $(PMX_TREE)/libf2c/dolio.c \
+ $(PMX_TREE)/libf2c/due.c $(PMX_TREE)/libf2c/endfile.c \
+ $(PMX_TREE)/libf2c/err.c $(PMX_TREE)/libf2c/fmt.c \
+ $(PMX_TREE)/libf2c/fmtlib.c $(PMX_TREE)/libf2c/ftell_.c \
+ $(PMX_TREE)/libf2c/iio.c $(PMX_TREE)/libf2c/ilnw.c \
+ $(PMX_TREE)/libf2c/inquire.c $(PMX_TREE)/libf2c/lread.c \
+ $(PMX_TREE)/libf2c/lwrite.c $(PMX_TREE)/libf2c/open.c \
+ $(PMX_TREE)/libf2c/rdfmt.c $(PMX_TREE)/libf2c/rewind.c \
+ $(PMX_TREE)/libf2c/rsfe.c $(PMX_TREE)/libf2c/rsli.c \
+ $(PMX_TREE)/libf2c/rsne.c $(PMX_TREE)/libf2c/sfe.c \
+ $(PMX_TREE)/libf2c/sue.c $(PMX_TREE)/libf2c/typesize.c \
+ $(PMX_TREE)/libf2c/uio.c $(PMX_TREE)/libf2c/util.c \
+ $(PMX_TREE)/libf2c/wref.c $(PMX_TREE)/libf2c/wrtfmt.c \
+ $(PMX_TREE)/libf2c/wsfe.c $(PMX_TREE)/libf2c/wsle.c \
+ $(PMX_TREE)/libf2c/wsne.c $(PMX_TREE)/libf2c/xwsne.c \
+ $(PMX_TREE)/libf2c/dtime_.c $(PMX_TREE)/libf2c/etime_.c \
+ $(am__append_1)
EXTRA_libf2c_a_SOURCES = $(PMX_TREE)/libf2c/uninit.c \
$(PMX_TREE)/libf2c/ftell64_.c $(PMX_TREE)/libf2c/pow_qq.c \
$(PMX_TREE)/libf2c/qbitbits.c $(PMX_TREE)/libf2c/qbitshft.c \
$(PMX_TREE)/libf2c/signbit.c
+lua_scripts = pmx2pdf
+scriptsdir = texmf-dist/scripts/pmx
+nodist_bin_SCRIPTS = $(am__append_2)
+all_scripts = $(lua_scripts) $(perl_scripts) $(shell_scripts)
+@WIN32_TRUE@@WIN32_WRAP_TRUE@wrappers = $(all_scripts:=.exe)
+@WIN32_TRUE@@WIN32_WRAP_TRUE@runscript = $(top_srcdir)/../../texk/texlive/w32_wrapper/runscript.exe
+texmfdir = $(datarootdir)/$(scriptsdir)
+dist_texmf_SCRIPTS = $(lua_scripts:=.lua)
dist_man1_MANS = pmx2pdf.1 pmxab.1 scor2prt.1
TESTS = pmx.test
+TESTS_ENVIRONMENT = test_src=$(srcdir)/$(PMX_TREE)/tests
DISTCLEANFILES = barsant* pmxaerr.dat
all: all-am
@@ -488,7 +503,7 @@ all: all-am
.SUFFIXES: .c .o .obj
am--refresh: Makefile
@:
-$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps)
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(srcdir)/../../texk/am/script_links.am $(am__configure_deps)
@for dep in $?; do \
case '$(am__configure_deps)' in \
*$$dep*) \
@@ -511,6 +526,7 @@ Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \
cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \
esac;
+$(srcdir)/../../texk/am/script_links.am:
$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
$(SHELL) ./config.status --recheck
@@ -573,6 +589,76 @@ pmxab$(EXEEXT): $(pmxab_OBJECTS) $(pmxab_DEPENDENCIES) $(EXTRA_pmxab_DEPENDENCIE
scor2prt$(EXEEXT): $(scor2prt_OBJECTS) $(scor2prt_DEPENDENCIES) $(EXTRA_scor2prt_DEPENDENCIES)
@rm -f scor2prt$(EXEEXT)
$(LINK) $(scor2prt_OBJECTS) $(scor2prt_LDADD) $(LIBS)
+install-dist_texmfSCRIPTS: $(dist_texmf_SCRIPTS)
+ @$(NORMAL_INSTALL)
+ @list='$(dist_texmf_SCRIPTS)'; test -n "$(texmfdir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(texmfdir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(texmfdir)" || exit 1; \
+ fi; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \
+ done | \
+ sed -e 'p;s,.*/,,;n' \
+ -e 'h;s|.*|.|' \
+ -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \
+ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \
+ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
+ if ($$2 == $$4) { files[d] = files[d] " " $$1; \
+ if (++n[d] == $(am__install_max)) { \
+ print "f", d, files[d]; n[d] = 0; files[d] = "" } } \
+ else { print "f", d "/" $$4, $$1 } } \
+ END { for (d in files) print "f", d, files[d] }' | \
+ while read type dir files; do \
+ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \
+ test -z "$$files" || { \
+ echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(texmfdir)$$dir'"; \
+ $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(texmfdir)$$dir" || exit $$?; \
+ } \
+ ; done
+
+uninstall-dist_texmfSCRIPTS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(dist_texmf_SCRIPTS)'; test -n "$(texmfdir)" || exit 0; \
+ files=`for p in $$list; do echo "$$p"; done | \
+ sed -e 's,.*/,,;$(transform)'`; \
+ dir='$(DESTDIR)$(texmfdir)'; $(am__uninstall_files_from_dir)
+install-nodist_binSCRIPTS: $(nodist_bin_SCRIPTS)
+ @$(NORMAL_INSTALL)
+ @list='$(nodist_bin_SCRIPTS)'; test -n "$(bindir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \
+ fi; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ if test -f "$$d$$p"; then echo "$$d$$p"; echo "$$p"; else :; fi; \
+ done | \
+ sed -e 'p;s,.*/,,;n' \
+ -e 'h;s|.*|.|' \
+ -e 'p;x;s,.*/,,;$(transform)' | sed 'N;N;N;s,\n, ,g' | \
+ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1; } \
+ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
+ if ($$2 == $$4) { files[d] = files[d] " " $$1; \
+ if (++n[d] == $(am__install_max)) { \
+ print "f", d, files[d]; n[d] = 0; files[d] = "" } } \
+ else { print "f", d "/" $$4, $$1 } } \
+ END { for (d in files) print "f", d, files[d] }' | \
+ while read type dir files; do \
+ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \
+ test -z "$$files" || { \
+ echo " $(INSTALL_SCRIPT) $$files '$(DESTDIR)$(bindir)$$dir'"; \
+ $(INSTALL_SCRIPT) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \
+ } \
+ ; done
+
+uninstall-nodist_binSCRIPTS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_bin_SCRIPTS)'; test -n "$(bindir)" || exit 0; \
+ files=`for p in $$list; do echo "$$p"; done | \
+ sed -e 's,.*/,,;$(transform)'`; \
+ dir='$(DESTDIR)$(bindir)'; $(am__uninstall_files_from_dir)
mostlyclean-compile:
-rm -f *.$(OBJEXT)
@@ -2884,6 +2970,20 @@ etime_.obj: $(PMX_TREE)/libf2c/etime_.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o etime_.obj `if test -f '$(PMX_TREE)/libf2c/etime_.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/etime_.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/etime_.c'; fi`
+w32getc.o: $(PMX_TREE)/w32getc.c
+@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT w32getc.o -MD -MP -MF $(DEPDIR)/w32getc.Tpo -c -o w32getc.o `test -f '$(PMX_TREE)/w32getc.c' || echo '$(srcdir)/'`$(PMX_TREE)/w32getc.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/w32getc.Tpo $(DEPDIR)/w32getc.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/w32getc.c' object='w32getc.o' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o w32getc.o `test -f '$(PMX_TREE)/w32getc.c' || echo '$(srcdir)/'`$(PMX_TREE)/w32getc.c
+
+w32getc.obj: $(PMX_TREE)/w32getc.c
+@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT w32getc.obj -MD -MP -MF $(DEPDIR)/w32getc.Tpo -c -o w32getc.obj `if test -f '$(PMX_TREE)/w32getc.c'; then $(CYGPATH_W) '$(PMX_TREE)/w32getc.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/w32getc.c'; fi`
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/w32getc.Tpo $(DEPDIR)/w32getc.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/w32getc.c' object='w32getc.obj' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o w32getc.obj `if test -f '$(PMX_TREE)/w32getc.c'; then $(CYGPATH_W) '$(PMX_TREE)/w32getc.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/w32getc.c'; fi`
+
uninit.o: $(PMX_TREE)/libf2c/uninit.c
@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT uninit.o -MD -MP -MF $(DEPDIR)/uninit.Tpo -c -o uninit.o `test -f '$(PMX_TREE)/libf2c/uninit.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/uninit.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/uninit.Tpo $(DEPDIR)/uninit.Po
@@ -3381,9 +3481,9 @@ distcleancheck: distclean
check-am: all-am
$(MAKE) $(AM_MAKEFLAGS) check-TESTS
check: check-am
-all-am: Makefile $(LIBRARIES) $(PROGRAMS) $(MANS)
+all-am: Makefile $(LIBRARIES) $(PROGRAMS) $(SCRIPTS) $(MANS)
installdirs:
- for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)"; do \
+ for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(texmfdir)" "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)"; do \
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
done
install: install-am
@@ -3441,13 +3541,14 @@ info: info-am
info-am:
-install-data-am: install-man
-
+install-data-am: install-dist_texmfSCRIPTS install-man
+ @$(NORMAL_INSTALL)
+ $(MAKE) $(AM_MAKEFLAGS) install-data-hook
install-dvi: install-dvi-am
install-dvi-am:
-install-exec-am: install-binPROGRAMS
+install-exec-am: install-binPROGRAMS install-nodist_binSCRIPTS
install-html: install-html-am
@@ -3488,11 +3589,13 @@ ps: ps-am
ps-am:
-uninstall-am: uninstall-binPROGRAMS uninstall-man
-
+uninstall-am: uninstall-binPROGRAMS uninstall-dist_texmfSCRIPTS \
+ uninstall-man uninstall-nodist_binSCRIPTS
+ @$(NORMAL_INSTALL)
+ $(MAKE) $(AM_MAKEFLAGS) uninstall-hook
uninstall-man: uninstall-man1
-.MAKE: check-am install-am install-strip
+.MAKE: check-am install-am install-data-am install-strip uninstall-am
.PHONY: CTAGS GTAGS all all-am am--refresh check check-TESTS check-am \
clean clean-binPROGRAMS clean-cscope clean-generic \
@@ -3502,20 +3605,59 @@ uninstall-man: uninstall-man1
distclean-generic distclean-tags distcleancheck distdir \
distuninstallcheck dvi dvi-am html html-am info info-am \
install install-am install-binPROGRAMS install-data \
- install-data-am install-dvi install-dvi-am install-exec \
- install-exec-am install-html install-html-am install-info \
- install-info-am install-man install-man1 install-pdf \
+ install-data-am install-data-hook install-dist_texmfSCRIPTS \
+ install-dvi install-dvi-am install-exec install-exec-am \
+ install-html install-html-am install-info install-info-am \
+ install-man install-man1 install-nodist_binSCRIPTS install-pdf \
install-pdf-am install-ps install-ps-am install-strip \
installcheck installcheck-am installdirs maintainer-clean \
maintainer-clean-generic mostlyclean mostlyclean-compile \
mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \
- uninstall-am uninstall-binPROGRAMS uninstall-man \
- uninstall-man1
+ uninstall-am uninstall-binPROGRAMS uninstall-dist_texmfSCRIPTS \
+ uninstall-hook uninstall-man uninstall-man1 \
+ uninstall-nodist_binSCRIPTS
# in case of an SVN repository
dist-hook:
rm -rf `find $(distdir) -name .svn`
+.PHONY: install-lua-links install-perl-links install-shell-links \
+ install-links uninstall-links
+@WIN32_TRUE@@WIN32_WRAP_TRUE@$(wrappers): $(runscript)
+@WIN32_TRUE@@WIN32_WRAP_TRUE@ $(LN_S) $(runscript) $@
+
+install-lua-links:
+@WIN32_FALSE@ $(MAKE) $(AM_MAKEFLAGS) TYPE=lua EXT=lua install-links
+
+install-perl-links:
+@WIN32_FALSE@ $(MAKE) $(AM_MAKEFLAGS) TYPE=perl EXT=pl install-links
+
+install-shell-links:
+@WIN32_FALSE@ $(MAKE) $(AM_MAKEFLAGS) TYPE=shell EXT=sh install-links
+
+# We support native builds, multiplatform or not, as well as distro builds.
+install-links:
+ @REL=`$(SHELL) $(srcdir)/../../build-aux/relpath '$(DESTDIR)' '$(bindir)' '$(datarootdir)'`; \
+ if test -z "$$REL"; then \
+ echo 'unable to compute relative path for linked $(TYPE) scripts' >&2; \
+ exit 1; \
+ fi; \
+ cd $(DESTDIR)$(bindir) && \
+ for f in $($(TYPE)_scripts); do \
+ rm -f $$f; \
+ echo "creating link '$$f' -> '$$REL/$(scriptsdir)/$$f.$(EXT)'"; \
+ $(LN_S) $$REL/$(scriptsdir)/$$f.$(EXT) $$f || exit 1; \
+ done
+
+uninstall-links:
+@WIN32_FALSE@ @for f in $(all_scripts); do \
+@WIN32_FALSE@ echo "rm -f '$(DESTDIR)$(bindir)/$$f'"; \
+@WIN32_FALSE@ rm -f "$(DESTDIR)$(bindir)/$$f"; \
+@WIN32_FALSE@ done
+
+install-data-hook: install-lua-links
+
+uninstall-hook: uninstall-links
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
diff --git a/Build/source/utils/pmx/README b/Build/source/utils/pmx/README
index fb6c3cc6c05..dd18f6d4796 100644
--- a/Build/source/utils/pmx/README
+++ b/Build/source/utils/pmx/README
@@ -10,4 +10,8 @@ From all the preprocessor defines arithchk could generate we only might need
'VAX' (most probably irrelevant) and 'NO_LONG_LONG' which can be handled by
the configure script. Thus an empty file arith.h suffices.
+================
+
+Actually, compiling neither signbit.c nor uninit.c the file arith.h is not
+used at all and can bbe omitted.
diff --git a/Build/source/utils/pmx/arith.h b/Build/source/utils/pmx/arith.h
deleted file mode 100644
index 0ee9308ca06..00000000000
--- a/Build/source/utils/pmx/arith.h
+++ /dev/null
@@ -1,3 +0,0 @@
-/* Copyright (C) 2012 Peter Breitenlohner <tex-live@tug.org>
- * You may freely use, modify and/or distribute this file.
- */
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/ChangeLog b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/ChangeLog
deleted file mode 100644
index 783c0504d7a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/ChangeLog
+++ /dev/null
@@ -1,19 +0,0 @@
-2012-04-01 Peter Breitenlohner <peb@mppmu.mpg.de>
-
- * 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 <peb@mppmu.mpg.de>
-
- * 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 <peb@mppmu.mpg.de>
-
- * 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 <tex-live@tug.org>
-You may freely use, modify and/or distribute this file.
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes
deleted file mode 100644
index d5b53310f25..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes
+++ /dev/null
@@ -1,16 +0,0 @@
-Changes applied to the pmx-2.6.17 tree as obtained from:
- http://www.ctan.org/tex-archive/support/pmx/
-
-Rename:
- pmx2617.c -> pmxab.c
-
-Remove:
- Makefile.in
- aclocal.m4
- configure
- depcomp
- f2c.h
- install-sh
- missing
- libf2c/arith.h
-
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-01-binary b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-01-binary
deleted file mode 100644
index 16819f76212..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-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.17.orig/libf2c/open.c pmx-2.6.17/libf2c/open.c
---- pmx-2.6.17.orig/libf2c/open.c 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/open.c 2012-03-29 17:12:53.000000000 +0200
-@@ -30,6 +30,9 @@
- #ifdef NON_ANSI_RW_MODES
- char *f__r_mode[2] = {"r", "r"};
- char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
-+#elif defined(WIN32)
-+char *f__r_mode[2] = {"rb", "rb"};
-+char *f__w_mode[4] = {"wb", "wb", "rb+", "rb+"};
- #else
- char *f__r_mode[2] = {"rb", "r"};
- char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-02-bugfix b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-02-bugfix
deleted file mode 100644
index 58de7f58ef1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-02-bugfix
+++ /dev/null
@@ -1,19 +0,0 @@
- This should really be fixed in the Fortran source.
-
-diff -ur pmx-2.6.17.orig/scor2prt.c pmx-2.6.17/scor2prt.c
---- pmx-2.6.17.orig/scor2prt.c 2012-03-25 00:00:34.000000000 +0100
-+++ pmx-2.6.17/scor2prt.c 2012-03-29 16:59:56.000000000 +0200
-@@ -22,10 +22,10 @@
- integer nvi[24], nsyst, nvnow;
- };
- struct all_2_ {
-- integer noinow, iorig[24], noinst, insetup;
-- real replacing;
-+ integer noinow, iorig[24], noinst;
-+ logical insetup, replacing;
- integer instnum[24];
-- real botv[24];
-+ logical botv[24];
- integer nvi[24], nsyst, nvnow;
- };
-
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-03-DOS-line-endings b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-03-DOS-line-endings
deleted file mode 100644
index 5e36c101b5a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-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.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h
---- pmx-2.6.17.orig/libf2c/fio.h 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200
-@@ -2,6 +2,10 @@
- #include "sysdep1.h"
- #endif
- #include "stdio.h"
-+#ifdef WIN32
-+extern int w32getc(FILE *f);
-+#define getc w32getc
-+#endif
- #include "errno.h"
- #ifndef NULL
- /* ANSI C */
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-04-MSVC-complex b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-04-MSVC-complex
deleted file mode 100644
index 4017e79ac99..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-04-MSVC-complex
+++ /dev/null
@@ -1,18 +0,0 @@
- _COMPLEX_DEFINED should be defined for MSVC, otherwise
- complex is redefined inconsistently in <math.h>.
-
- Mail from Akira, 31 Mar 2012 21:36:26.
-
-diff -ur pmx-2.6.17.orig/libf2c/f2c.h pmx-2.6.17/libf2c/f2c.h
---- pmx-2.6.17.orig/libf2c/f2c.h 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/f2c.h 2012-04-01 14:50:19.000000000 +0200
-@@ -13,6 +13,9 @@
- typedef short int shortint;
- typedef float real;
- typedef double doublereal;
-+#ifdef WIN32
-+#define _COMPLEX_DEFINED 1
-+#endif
- typedef struct { real r, i; } complex;
- typedef struct { doublereal r, i; } doublecomplex;
- typedef long int logical;
diff --git a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-05-FreeBSD-off_t b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-05-FreeBSD-off_t
deleted file mode 100644
index 8131c75d023..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/patch-05-FreeBSD-off_t
+++ /dev/null
@@ -1,13 +0,0 @@
- On FreeBSD (and maybe others) we need <sys/types.h> for off_t.
-
-diff -ur pmx-2.6.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h
---- pmx-2.6.17.orig/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200
-+++ pmx-2.6.17/libf2c/fio.h 2012-04-23 10:06:01.000000000 +0200
-@@ -1,6 +1,7 @@
- #ifndef SYSDEP_H_INCLUDED
- #include "sysdep1.h"
- #endif
-+#include <sys/types.h> /* for off_t */
- #include "stdio.h"
- #ifdef WIN32
- extern int w32getc(FILE *f);
diff --git a/Build/source/utils/pmx/pmx-2.6.17/AUTHORS b/Build/source/utils/pmx/pmx-2.6.17/AUTHORS
deleted file mode 100644
index 2fa3681a96f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/AUTHORS
+++ /dev/null
@@ -1 +0,0 @@
-Don Simons dsimons@roadrunner.com
diff --git a/Build/source/utils/pmx/pmx-2.6.17/COPYING b/Build/source/utils/pmx/pmx-2.6.17/COPYING
deleted file mode 100644
index 92bc3d8dc11..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/COPYING
+++ /dev/null
@@ -1,622 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- 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.17/ChangeLog b/Build/source/utils/pmx/pmx-2.6.17/ChangeLog
deleted file mode 100644
index bc696ddb77e..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/ChangeLog
+++ /dev/null
@@ -1,200 +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.
-
diff --git a/Build/source/utils/pmx/pmx-2.6.17/INSTALL b/Build/source/utils/pmx/pmx-2.6.17/INSTALL
deleted file mode 100644
index 7d1c323beae..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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 `<wchar.h>' 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.17/Makefile.am b/Build/source/utils/pmx/pmx-2.6.17/Makefile.am
deleted file mode 100644
index 486d79192d4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/Makefile.am
+++ /dev/null
@@ -1,8 +0,0 @@
-SUBDIRS = libf2c
-DIST_SUBDIRS = libf2c
-bin_PROGRAMS = pmxab scor2prt
-pmxab_SOURCES = libf2c/f2c.h pmx2617.c
-scor2prt_SOURCES = libf2c/f2c.h scor2prt.c
-pmxab_LDADD = libf2c/libf2c.a
-scor2prt_LDADD = libf2c/libf2c.a
-EXTRA_DIST = pmx2617.f scor2prt.f
diff --git a/Build/source/utils/pmx/pmx-2.6.17/NEWS b/Build/source/utils/pmx/pmx-2.6.17/NEWS
deleted file mode 100644
index b16df900f2c..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/NEWS
+++ /dev/null
@@ -1,46 +0,0 @@
-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.
-
diff --git a/Build/source/utils/pmx/pmx-2.6.17/README b/Build/source/utils/pmx/pmx-2.6.17/README
deleted file mode 100644
index c28f813df70..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/README
+++ /dev/null
@@ -1,11 +0,0 @@
-This is PMX, version 2.6.17. 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.17/config.h.in b/Build/source/utils/pmx/pmx-2.6.17/config.h.in
deleted file mode 100644
index 5706e9a0864..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/config.h.in
+++ /dev/null
@@ -1,90 +0,0 @@
-/* config.h.in. Generated from configure.ac by autoheader. */
-
-/* Define to 1 if you have the `atexit' function. */
-#undef HAVE_ATEXIT
-
-/* Define to 1 if you have the <fenv.h> header file. */
-#undef HAVE_FENV_H
-
-/* Define to 1 if you have the `floor' function. */
-#undef HAVE_FLOOR
-
-/* Define to 1 if you have the <inttypes.h> header file. */
-#undef HAVE_INTTYPES_H
-
-/* Define to 1 if you have the `m' library (-lm). */
-#undef HAVE_LIBM
-
-/* Define to 1 if your system has a GNU libc compatible `malloc' function, and
- to 0 otherwise. */
-#undef HAVE_MALLOC
-
-/* Define to 1 if you have the <memory.h> header file. */
-#undef HAVE_MEMORY_H
-
-/* Define to 1 if you have the `memset' function. */
-#undef HAVE_MEMSET
-
-/* Define to 1 if you have the `pow' function. */
-#undef HAVE_POW
-
-/* Define to 1 if your system has a GNU libc compatible `realloc' function,
- and to 0 otherwise. */
-#undef HAVE_REALLOC
-
-/* Define to 1 if you have the `sqrt' function. */
-#undef HAVE_SQRT
-
-/* Define to 1 if you have the <stdint.h> header file. */
-#undef HAVE_STDINT_H
-
-/* Define to 1 if you have the <stdlib.h> header file. */
-#undef HAVE_STDLIB_H
-
-/* Define to 1 if you have the <strings.h> header file. */
-#undef HAVE_STRINGS_H
-
-/* Define to 1 if you have the <string.h> header file. */
-#undef HAVE_STRING_H
-
-/* Define to 1 if you have the <sys/stat.h> header file. */
-#undef HAVE_SYS_STAT_H
-
-/* Define to 1 if you have the <sys/types.h> header file. */
-#undef HAVE_SYS_TYPES_H
-
-/* Define to 1 if you have the <unistd.h> header file. */
-#undef HAVE_UNISTD_H
-
-/* Name of package */
-#undef PACKAGE
-
-/* Define to the address where bug reports for this package should be sent. */
-#undef PACKAGE_BUGREPORT
-
-/* Define to the full name of this package. */
-#undef PACKAGE_NAME
-
-/* Define to the full name and version of this package. */
-#undef PACKAGE_STRING
-
-/* Define to the one symbol short name of this package. */
-#undef PACKAGE_TARNAME
-
-/* Define to the version of this package. */
-#undef PACKAGE_VERSION
-
-/* Define to 1 if you have the ANSI C header files. */
-#undef STDC_HEADERS
-
-/* Version number of package */
-#undef VERSION
-
-/* Define to rpl_malloc if the replacement function should be used. */
-#undef malloc
-
-/* Define to rpl_realloc if the replacement function should be used. */
-#undef realloc
-
-/* Define to `unsigned int' if <sys/types.h> does not define. */
-#undef size_t
diff --git a/Build/source/utils/pmx/pmx-2.6.17/configure.ac b/Build/source/utils/pmx/pmx-2.6.17/configure.ac
deleted file mode 100644
index db938b7f1f6..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/configure.ac
+++ /dev/null
@@ -1,37 +0,0 @@
-# -*- Autoconf -*-
-# Process this file with autoconf to produce a configure script.
-
-AC_PREREQ([2.63])
-AC_INIT([pmx], [2.6.17], [dsimons@roadrunner.com])
-AC_CONFIG_SRCDIR([pmx2617.c])
-AC_CONFIG_HEADERS([config.h])
-AM_INIT_AUTOMAKE(pmx, 2.6.17)
-
-# Checks for programs.
-AC_PROG_CC
-
-# Checks for libraries.
-AC_CHECK_LIB([m], [sqrt])
-
-# Checks for header files.
-AC_CHECK_HEADERS([fenv.h])
-AC_CHECK_HEADERS([stdlib.h])
-AC_CHECK_HEADERS([string.h])
-
-
-# Checks for typedefs, structures, and compiler characteristics.
-AC_TYPE_SIZE_T
-
-# Checks for library functions.
-AC_CHECK_FUNCS([sqrt])
-AC_CHECK_FUNCS([atexit])
-AC_CHECK_FUNCS([floor])
-AC_CHECK_FUNCS([memset])
-AC_CHECK_FUNCS([pow])
-AC_FUNC_MALLOC
-AC_FUNC_REALLOC
-
-
-
-AC_CONFIG_FILES([Makefile])
-AC_OUTPUT
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/Makefile b/Build/source/utils/pmx/pmx-2.6.17/libf2c/Makefile
deleted file mode 100644
index 528a7418bbb..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-CFLAGS = -Wall -W -pedantic -O2 -DNON_UNIX_STDIO -fPIC
-
-MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\
- getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\
- derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o
-POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
-CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
-DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
-REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
- r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
- r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
- r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
-DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
- d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
- d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
- d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
- d_sqrt.o d_tan.o d_tanh.o
-INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\
- lbitbits.o lbitshft.o
-HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
-CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
-EFL = ef1asc_.o ef1cmc_.o
-CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o
-I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\
- fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\
- open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\
- typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
-QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o
-TIME = dtime_.o etime_.o
-
-OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
- $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME)
-
-all: arith.h f2c.h signal1.h sysdep1.h libf2c.a
-
-libf2c.a: $(OFILES)
- ar r libf2c.a $?
-
-f77vers.o: f77vers.c
-
-i77vers.o: i77vers.c
-
-
-arith.h: arithchk.c
- $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\
- $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm
- ./a.out >arith.h
- rm -f a.out arithchk.o
-
-clean:
- rm -f libf2c.a *.o arith.h
-
-
-EMPTY_AUTOMAKE_TARGETS = dvi pdf ps info html tags ctags install install-data install-exec uninstall install-dvi install-html install-info install-ps install-pdf installdirs check installcheck mostlyclean distclean maintainer-clean
-.PHONY: $(EMPTY_AUTOMAKE_TARGETS)
-$(EMPTY_AUTOMAKE_TARGETS):
-
-DISTFILES =
-distdir: $(DISTFILES)
- cp Notice Makefile README *.h *.c $(distdir)
- cp f2c.h $(top_distdir)
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/Notice b/Build/source/utils/pmx/pmx-2.6.17/libf2c/Notice
deleted file mode 100644
index 261b719bc57..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/Notice
+++ /dev/null
@@ -1,23 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
-
-Permission to use, copy, modify, and distribute this software
-and its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice appear in all
-copies and that both that the copyright notice and this
-permission notice and warranty disclaimer appear in supporting
-documentation, and that the names of AT&T, Bell Laboratories,
-Lucent or Bellcore or any of their entities not be used in
-advertising or publicity pertaining to distribution of the
-software without specific, written prior permission.
-
-AT&T, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness. In no event shall AT&T, Lucent or
-Bellcore be liable for any special, indirect or consequential
-damages or any damages whatsoever resulting from loss of use,
-data or profits, whether in an action of contract, negligence or
-other tortious action, arising out of or in connection with the
-use or performance of this software.
-****************************************************************/
-
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/README b/Build/source/utils/pmx/pmx-2.6.17/libf2c/README
deleted file mode 100644
index 73388d0bd4f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/README
+++ /dev/null
@@ -1,329 +0,0 @@
-If your system has a double drem() function such that drem(a,b)
-is the IEEE remainder function (with double a, b), then you may
-wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
-
-On machines, such as those using a DEC Alpha processor, on which
-sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and
-sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by
-removing the first occurrence of "long " on each line containing
-"long ". On Unix systems, you can do this by issuing the commands
- mv f2c.h f2c.h0
- sed 's/long int /int /' f2c.h0 >f2c.h
-On such machines, one can enable INTEGER*8 by uncommenting the typedefs
-of longint and ulongint in f2c.h and adjusting them, so they read
- typedef long longint;
- typedef unsigned long ulongint;
-and by compiling libf2c with -DAllow_TYQUAD, as discussed below.
-
-
-Most of the routines in libf2c are support routines for Fortran
-intrinsic functions or for operations that f2c chooses not
-to do "in line". There are a few exceptions, summarized below --
-functions and subroutines that appear to your program as ordinary
-external Fortran routines.
-
-If you use the REAL valued functions listed below (ERF, ERFC,
-DTIME, and ETIME) with "f2c -R", then you need to compile the
-corresponding source files with -DREAL=float. To do this, it is
-perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile.
-
-1. CALL ABORT prints a message and causes a core dump.
-
-2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
- error functions (with x REAL and d DOUBLE PRECISION);
- DERF must be declared DOUBLE PRECISION in your program.
- Both ERF and DERF assume your C library provides the
- underlying erf() function (which not all systems do).
-
-3. ERFC(r) and DERFC(d) are the complementary error functions:
- ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
- (except that their results may be more accurate than
- explicitly evaluating the above formulae would give).
- Again, ERFC and r are REAL, and DERFC and d are DOUBLE
- PRECISION (and must be declared as such in your program),
- and ERFC and DERFC rely on your system's erfc().
-
-4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
- variable, sets s to the n-th command-line argument (or to
- all blanks if there are fewer than n command-line arguments);
- CALL GETARG(0,s) sets s to the name of the program (on systems
- that support this feature). See IARGC below.
-
-5. CALL GETENV(name, value), where name and value are of type
- CHARACTER, sets value to the environment value, $name, of
- name (or to blanks if $name has not been set).
-
-6. NARGS = IARGC() sets NARGS to the number of command-line
- arguments (an INTEGER value).
-
-7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
- EXTERNAL procedure, arranges for func to be invoked when n
- occurs (on systems where this makes sense).
-
-If your compiler complains about the signal calls in main.c, s_paus.c,
-and signal_.c, you may need to adjust signal1.h suitably. See the
-comments in signal1.h.
-
-8. ETIME(ARR) and DTIME(ARR) are REAL functions that return
- execution times. ARR is declared REAL ARR(2). The elapsed
- user and system CPU times are stored in ARR(1) and ARR(2),
- respectively. ETIME returns the total elapsed CPU time,
- i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU
- time since the previous call on DTIME.
-
-9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
- cmd to the system's command processor (on systems where
- this can be done).
-
-10. CALL FLUSH flushes all buffers.
-
-11. FTELL(i) is an INTEGER function that returns the current
- offset of Fortran unit i (or -1 if unit i is not open).
-
-12. CALL FSEEK(i, offset, whence, *errlab) attemps to move
- Fortran unit i to the specified offset: absolute offset
- if whence = 0; relative to the current offset if whence = 1;
- relative to the end of the file if whence = 2. It branches
- to label errlab if unit i is not open or if the call
- otherwise fails.
-
-The routines whose objects are makefile.u's $(I77) are for I/O.
-The following comments apply to them.
-
-If your system lacks /usr/include/local.h ,
-then you should create an appropriate local.h in
-this directory. An appropriate local.h may simply
-be empty, or it may #define VAX or #define CRAY
-(or whatever else you must do to make fp.h work right).
-Alternatively, edit fp.h to suite your machine.
-
-If your system lacks /usr/include/fcntl.h , then you
-should simply create an empty fcntl.h in this directory.
-If your compiler then complains about creat and open not
-having a prototype, compile with OPEN_DECL defined.
-On many systems, open and creat are declared in fcntl.h .
-
-If your system's sprintf does not work the way ANSI C
-specifies -- specifically, if it does not return the
-number of characters transmitted -- then insert the line
-
-#define USE_STRLEN
-
-at the end of fmt.h . This is necessary with
-at least some versions of Sun software.
-In particular, if you get a warning about an improper
-pointer/integer combination in compiling wref.c, then
-you need to compile with -DUSE_STRLEN .
-
-If your system's fopen does not like the ANSI binary
-reading and writing modes "rb" and "wb", then you should
-compile open.c with NON_ANSI_RW_MODES #defined.
-
-If you get error messages about references to cf->_ptr
-and cf->_base when compiling wrtfmt.c and wsfe.c or to
-stderr->_flag when compiling err.c, then insert the line
-
-#define NON_UNIX_STDIO
-
-at the beginning of fio.h, and recompile everything (or
-at least those modules that contain NON_UNIX_STDIO).
-
-Unformatted sequential records consist of a length of record
-contents, the record contents themselves, and the length of
-record contents again (for backspace). Prior to 17 Oct. 1991,
-the length was of type int; now it is of type long, but you
-can change it back to int by inserting
-
-#define UIOLEN_int
-
-at the beginning of fio.h. This affects only sue.c and uio.c .
-
-If you have a really ancient K&R C compiler that does not understand
-void, add -Dvoid=int to the definition of CFLAGS in the makefile.
-
-On VAX, Cray, or Research Tenth-Edition Unix systems, you may
-need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS
-to make fp.h work correctly. Alternatively, you may need to
-edit fp.h to suit your machine.
-
-If your compiler complains about the signal calls in main.c, s_paus.c,
-and signal_.c, you may need to adjust signal1.h suitably. See the
-comments in signal1.h.
-
-You may need to supply the following non-ANSI routines:
-
- fstat(int fileds, struct stat *buf) is similar
-to stat(char *name, struct stat *buf), except that
-the first argument, fileds, is the file descriptor
-returned by open rather than the name of the file.
-fstat is used in the system-dependent routine
-canseek (in the libf2c source file err.c), which
-is supposed to return 1 if it's possible to issue
-seeks on the file in question, 0 if it's not; you may
-need to suitably modify err.c . On non-UNIX systems,
-you can avoid references to fstat and stat by compiling
-with NON_UNIX_STDIO defined; in that case, you may need
-to supply access(char *Name,0), which is supposed to
-return 0 if file Name exists, nonzero otherwise.
-
- char * mktemp(char *buf) is supposed to replace the
-6 trailing X's in buf with a unique number and then
-return buf. The idea is to get a unique name for
-a temporary file.
-
-On non-UNIX systems, you may need to change a few other,
-e.g.: the form of name computed by mktemp() in endfile.c and
-open.c; the use of the open(), close(), and creat() system
-calls in endfile.c, err.c, open.c; and the modes in calls on
-fopen() and fdopen() (and perhaps the use of fdopen() itself
--- it's supposed to return a FILE* corresponding to a given
-an integer file descriptor) in err.c and open.c (component ufmt
-of struct unit is 1 for formatted I/O -- text mode on some systems
--- and 0 for unformatted I/O -- binary mode on some systems).
-Compiling with -DNON_UNIX_STDIO omits all references to creat()
-and almost all references to open() and close(), the exception
-being in the function f__isdev() (in open.c).
-
-If you wish to use translated Fortran that has funny notions
-of record length for direct unformatted I/O (i.e., that assumes
-RECL= values in OPEN statements are not bytes but rather counts
-of some other units -- e.g., 4-character words for VMS), then you
-should insert an appropriate #define for url_Adjust at the
-beginning of open.c . For VMS Fortran, for example,
-#define url_Adjust(x) x *= 4
-would suffice.
-
-By default, Fortran I/O units 5, 6, and 0 are pre-connected to
-stdin, stdout, and stderr, respectively. You can change this
-behavior by changing f_init() in err.c to suit your needs.
-Note that f2c assumes READ(*... means READ(5... and WRITE(*...
-means WRITE(6... . Moreover, an OPEN(n,... statement that does
-not specify a file name (and does not specify STATUS='SCRATCH')
-assumes FILE='fort.n' . You can change this by editing open.c
-and endfile.c suitably.
-
-Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units
-0, 1, ..., 99 are available, i.e., the highest allowed unit number
-is MXUNIT - 1.
-
-Lines protected from compilation by #ifdef Allow_TYQUAD
-are for a possible extension to 64-bit integers in which
-integer = int = 32 bits and longint = long = 64 bits.
-
-The makefile does not attempt to compile pow_qq.c, qbitbits.c,
-and qbitshft.c, which are meant for use with INTEGER*8. To use
-INTEGER*8, you must modify f2c.h to declare longint and ulongint
-appropriately; then add $(QINT) to the end of the makefile's
-dependency list for libf2c.a (if makefile is a copy of makefile.u;
-for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj
-to the library's dependency list and adjust libf2c.lbc or libf2c.sy
-accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS
-assignment. To make longint and ulongint available, it may suffice
-to add -DINTEGER_STAR_8 to the CFLAGS assignment.
-
-Following Fortran 90, s_cat.c and s_copy.c allow the target of a
-(character string) assignment to be appear on its right-hand, at
-the cost of some extra overhead for all run-time concatenations.
-If you prefer the extra efficiency that comes with the Fortran 77
-requirement that the left-hand side of a character assignment not
-be involved in the right-hand side, compile s_cat.c and s_copy.c
-with -DNO_OVERWRITE .
-
-Extensions (Feb. 1993) to NAMELIST processing:
- 1. Reading a ? instead of &name (the start of a namelist) causes
-the namelist being sought to be written to stdout (unit 6);
-to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
- 2. Reading the wrong namelist name now leads to an error message
-and an attempt to skip input until the right namelist name is found;
-to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
- 3. Namelist writes now insert newlines before each variable; to omit
-this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
- 4. (Sept. 1995) When looking for the &name that starts namelist
-input, lines whose first non-blank character is something other
-than &, $, or ? are treated as comment lines and ignored, unless
-rsne.c is compiled with -DNo_Namelist_Comments.
-
-Nonstandard extension (Feb. 1993) to open: for sequential files,
-ACCESS='APPEND' (or access='anything else starting with "A" or "a"')
-causes the file to be positioned at end-of-file, so a write will
-append to the file.
-
-Some buggy Fortran programs use unformatted direct I/O to write
-an incomplete record and later read more from that record than
-they have written. For records other than the last, the unwritten
-portion of the record reads as binary zeros. The last record is
-a special case: attempting to read more from it than was written
-gives end-of-file -- which may help one find a bug. Some other
-Fortran I/O libraries treat the last record no differently than
-others and thus give no help in finding the bug of reading more
-than was written. If you wish to have this behavior, compile
-uio.c with -DPad_UDread .
-
-If you want to be able to catch write failures (e.g., due to a
-disk being full) with an ERR= specifier, compile dfe.c, due.c,
-sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to
-slower execution and more I/O, but should make ERR= work as
-expected, provided fflush returns an error return when its
-physical write fails.
-
-Carriage controls are meant to be interpreted by the UNIX col
-program (or a similar program). Sometimes it's convenient to use
-only ' ' as the carriage control character (normal single spacing).
-If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted
-external output lines will have an initial ' ' quietly omitted,
-making use of the col program unnecessary with output that only
-has ' ' for carriage control.
-
-The Fortran 77 Standard leaves it up to the implementation whether
-formatted writes of floating-point numbers of absolute value < 1 have
-a zero before the decimal point. By default, libI77 omits such
-superfluous zeros, but you can cause them to appear by compiling
-lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 .
-
-If your (Unix) system lacks a ranlib command, you don't need it.
-Either comment out the makefile's ranlib invocation, or install
-a harmless "ranlib" command somewhere in your PATH, such as the
-one-line shell script
-
- exit 0
-
-or (on some systems)
-
- exec /usr/bin/ar lts $1 >/dev/null
-
-By default, the routines that implement complex and double complex
-division, c_div.c and z_div.c, call sig_die to print an error message
-and exit if they see a divisor of 0, as this is sometimes helpful for
-debugging. On systems with IEEE arithmetic, compiling c_div.c and
-z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both
-the real and imaginary parts of the result to +INFINITY if the
-numerator is nonzero, or to NaN if it vanishes.
-
-Nowadays most Unix and Linux systems have function
- int ftruncate(int fildes, off_t len);
-defined in system header file unistd.h that adjusts the length of file
-descriptor fildes to length len. Unless endfile.c is compiled with
--DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if
-necessary to shorten files. If your system lacks ftruncate(), compile
-endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more
-portable scheme of shortening a file by copying to a temporary file
-and back again.
-
-The initializations for "f2c -trapuv" are done by _uninit_f2c(),
-whose source is uninit.c, introduced June 2001. On IEEE-arithmetic
-systems, _uninit_f2c should initialize floating-point variables to
-signaling NaNs and, at its first invocation, should enable the
-invalid operation exception. Alas, the rules for distinguishing
-signaling from quiet NaNs were not specified in the IEEE P754 standard,
-nor were the precise means of enabling and disabling IEEE-arithmetic
-exceptions, and these details are thus system dependent. There are
-#ifdef's in uninit.c that specify them for some popular systems. If
-yours is not one of these systems, it may take some detective work to
-discover the appropriate details for your system. Sometimes it helps
-to look in the standard include directories for header files with
-relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and
-it may be simplest to run experiments to see what distinguishes a
-signaling from a quiet NaN. (If x is initialized to a signaling
-NaN and the invalid operation exception is masked off, as it should
-be by default on IEEE-arithmetic systems, then computing, say,
-y = x + 1 will yield a quiet NaN.)
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/abort_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/abort_.c
deleted file mode 100644
index fa5aae6b716..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/arithchk.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/arithchk.c
deleted file mode 100644
index 94c93e2f2a4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/arithchk.c
+++ /dev/null
@@ -1,225 +0,0 @@
-/****************************************************************
-Copyright (C) 1997, 1998, 2000 Lucent Technologies
-All Rights Reserved
-
-Permission to use, copy, modify, and distribute this software and
-its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice appear in all
-copies and that both that the copyright notice and this
-permission notice and warranty disclaimer appear in supporting
-documentation, and that the name of Lucent or any of its entities
-not be used in advertising or publicity pertaining to
-distribution of the software without specific, written prior
-permission.
-
-LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
-INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
-IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
-SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
-IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
-ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
-THIS SOFTWARE.
-****************************************************************/
-
-/* Try to deduce arith.h from arithmetic properties. */
-
-#include <stdio.h>
-#include <math.h>
-#include <errno.h>
-
-#ifdef NO_FPINIT
-#define fpinit_ASL()
-#else
-#ifndef KR_headers
-extern
-#ifdef __cplusplus
- "C"
-#endif
- void fpinit_ASL(void);
-#endif /*KR_headers*/
-#endif /*NO_FPINIT*/
-
- static int dalign;
- typedef struct
-Akind {
- char *name;
- int kind;
- } Akind;
-
- static Akind
-IEEE_8087 = { "IEEE_8087", 1 },
-IEEE_MC68k = { "IEEE_MC68k", 2 },
-IBM = { "IBM", 3 },
-VAX = { "VAX", 4 },
-CRAY = { "CRAY", 5};
-
- static double t_nan;
-
- static Akind *
-Lcheck()
-{
- union {
- double d;
- long L[2];
- } u;
- struct {
- double d;
- long L;
- } x[2];
-
- if (sizeof(x) > 2*(sizeof(double) + sizeof(long)))
- dalign = 1;
- u.L[0] = u.L[1] = 0;
- u.d = 1e13;
- if (u.L[0] == 1117925532 && u.L[1] == -448790528)
- return &IEEE_MC68k;
- if (u.L[1] == 1117925532 && u.L[0] == -448790528)
- return &IEEE_8087;
- if (u.L[0] == -2065213935 && u.L[1] == 10752)
- return &VAX;
- if (u.L[0] == 1267827943 && u.L[1] == 704643072)
- return &IBM;
- return 0;
- }
-
- static Akind *
-icheck()
-{
- union {
- double d;
- int L[2];
- } u;
- struct {
- double d;
- int L;
- } x[2];
-
- if (sizeof(x) > 2*(sizeof(double) + sizeof(int)))
- dalign = 1;
- u.L[0] = u.L[1] = 0;
- u.d = 1e13;
- if (u.L[0] == 1117925532 && u.L[1] == -448790528)
- return &IEEE_MC68k;
- if (u.L[1] == 1117925532 && u.L[0] == -448790528)
- return &IEEE_8087;
- if (u.L[0] == -2065213935 && u.L[1] == 10752)
- return &VAX;
- if (u.L[0] == 1267827943 && u.L[1] == 704643072)
- return &IBM;
- return 0;
- }
-
-char *emptyfmt = ""; /* avoid possible warning message with printf("") */
-
- static Akind *
-ccheck()
-{
- union {
- double d;
- long L;
- } u;
- long Cray1;
-
- /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */
- Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762;
- if (printf(emptyfmt, Cray1) >= 0)
- Cray1 = 1000000*Cray1 + 693716;
- if (printf(emptyfmt, Cray1) >= 0)
- Cray1 = 1000000*Cray1 + 115456;
- u.d = 1e13;
- if (u.L == Cray1)
- return &CRAY;
- return 0;
- }
-
- static int
-fzcheck()
-{
- double a, b;
- int i;
-
- a = 1.;
- b = .1;
- for(i = 155;; b *= b, i >>= 1) {
- if (i & 1) {
- a *= b;
- if (i == 1)
- break;
- }
- }
- b = a * a;
- return b == 0.;
- }
-
- static int
-need_nancheck()
-{
- double t;
-
- errno = 0;
- t = log(t_nan);
- if (errno == 0)
- return 1;
- errno = 0;
- t = sqrt(t_nan);
- return errno == 0;
- }
-
-main()
-{
- FILE *f;
- Akind *a = 0;
- int Ldef = 0;
-
- fpinit_ASL();
-#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */
- f = fopen("arith.h", "w");
- if (!f) {
- printf("Cannot open arith.h\n");
- return 1;
- }
-#else
- f = stdout;
-#endif
-
- if (sizeof(double) == 2*sizeof(long))
- a = Lcheck();
- else if (sizeof(double) == 2*sizeof(int)) {
- Ldef = 1;
- a = icheck();
- }
- else if (sizeof(double) == sizeof(long))
- a = ccheck();
- if (a) {
- fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n",
- a->name, a->kind);
- if (Ldef)
- fprintf(f, "#define Long int\n#define Intcast (int)(long)\n");
- if (dalign)
- fprintf(f, "#define Double_Align\n");
- if (sizeof(char*) == 8)
- fprintf(f, "#define X64_bit_pointers\n");
-#ifndef NO_LONG_LONG
- if (sizeof(long long) < 8)
-#endif
- fprintf(f, "#define NO_LONG_LONG\n");
- if (a->kind <= 2) {
- if (fzcheck())
- fprintf(f, "#define Sudden_Underflow\n");
- t_nan = -a->kind;
- if (need_nancheck())
- fprintf(f, "#define NANCHECK\n");
- }
- return 0;
- }
- fprintf(f, "/* Unknown arithmetic */\n");
- return 1;
- }
-
-#ifdef __sun
-#ifdef __i386
-/* kludge for Intel Solaris */
-void fpsetprec(int x) { }
-#endif
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/backspac.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/backspac.c
deleted file mode 100644
index 908a61897aa..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_abs.c
deleted file mode 100644
index 858f2c8b4b1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_cos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_cos.c
deleted file mode 100644
index 29fe49e3cda..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_div.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_div.c
deleted file mode 100644
index 59425e7aaad..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_exp.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_exp.c
deleted file mode 100644
index f46508d35b1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_log.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_log.c
deleted file mode 100644
index a0ba3f0d8d2..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_sin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_sin.c
deleted file mode 100644
index c8bc30f2d69..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/c_sqrt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/c_sqrt.c
deleted file mode 100644
index 1678c534d60..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/cabs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/cabs.c
deleted file mode 100644
index 84750d505cf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/close.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/close.c
deleted file mode 100644
index e958c7172a8..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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<MXUNIT;i++)
- {
- xx.cunit=i;
- (void) f_clos(&xx);
- }
- }
-}
- int
-#ifdef KR_headers
-flush_()
-#else
-flush_(void)
-#endif
-{ int i;
- for(i=0;i<MXUNIT;i++)
- if(f__units[i].ufd != NULL && f__units[i].uwrt)
- fflush(f__units[i].ufd);
-return 0;
-}
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_abs.c
deleted file mode 100644
index 2f7a153c2e3..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_abs.c
+++ /dev/null
@@ -1,18 +0,0 @@
-#include "f2c.h"
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-#ifdef KR_headers
-double d_abs(x) doublereal *x;
-#else
-double d_abs(doublereal *x)
-#endif
-{
-if(*x >= 0)
- return(*x);
-return(- *x);
-}
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_acos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_acos.c
deleted file mode 100644
index 69005b56d76..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_asin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_asin.c
deleted file mode 100644
index d5196ab101e..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_atan.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_atan.c
deleted file mode 100644
index d8856f8d698..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_atn2.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_atn2.c
deleted file mode 100644
index 56113850ab9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_cnjg.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cnjg.c
deleted file mode 100644
index 38471d9bc0e..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_cos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cos.c
deleted file mode 100644
index 12def9ad0fd..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_cosh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_cosh.c
deleted file mode 100644
index 9214c7a0d82..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_dim.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_dim.c
deleted file mode 100644
index 627ddb690fd..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_exp.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_exp.c
deleted file mode 100644
index e9ab5d4425c..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_imag.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_imag.c
deleted file mode 100644
index d17b9dd591d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_int.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_int.c
deleted file mode 100644
index 6da4ce35e92..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_lg10.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_lg10.c
deleted file mode 100644
index 664c19d9e99..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_log.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_log.c
deleted file mode 100644
index e74be02c54e..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_mod.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_mod.c
deleted file mode 100644
index 3766d9fa828..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_nint.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_nint.c
deleted file mode 100644
index 66f2dd0ee67..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_prod.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_prod.c
deleted file mode 100644
index f9f348b03dd..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_sign.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sign.c
deleted file mode 100644
index d06e0d19231..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_sin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sin.c
deleted file mode 100644
index ebd4eec5eeb..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_sinh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sinh.c
deleted file mode 100644
index 2479a6fab22..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_sqrt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_sqrt.c
deleted file mode 100644
index a7fa66c00aa..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_tan.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_tan.c
deleted file mode 100644
index 7d252c4d5cf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/d_tanh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/d_tanh.c
deleted file mode 100644
index 415b58508b3..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/derf_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/derf_.c
deleted file mode 100644
index d935d315213..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/derfc_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/derfc_.c
deleted file mode 100644
index 18f5c619b6f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/dfe.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/dfe.c
deleted file mode 100644
index c6b10d0e9c3..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/dolio.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/dolio.c
deleted file mode 100644
index 4070d879012..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/dtime_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/dtime_.c
deleted file mode 100644
index 6a09b3e9837..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/due.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/due.c
deleted file mode 100644
index a7f4cec4673..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/ef1asc_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/ef1asc_.c
deleted file mode 100644
index 70be0bc2e0b..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/ef1cmc_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/ef1cmc_.c
deleted file mode 100644
index 4b420ae6465..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/endfile.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/endfile.c
deleted file mode 100644
index 04020d3802d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/erf_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/erf_.c
deleted file mode 100644
index 532fec61c86..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/erfc_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/erfc_.c
deleted file mode 100644
index 6f6c9f10644..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/err.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/err.c
deleted file mode 100644
index b81ffc111f0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/etime_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/etime_.c
deleted file mode 100644
index 2d9a36d8a31..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/exit_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/exit_.c
deleted file mode 100644
index 08e9d07067c..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/f2c.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/f2c.h
deleted file mode 100644
index a91de9bf804..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/f2c.h
+++ /dev/null
@@ -1,226 +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. */
-typedef long long longint; /* system-dependent */
-typedef unsigned long long ulongint; /* system-dependent */
-#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b)))
-#define qbit_set(a,b) ((a) | ((ulongint)1 << (b)))
-#endif
-
-#define TRUE_ (1)
-#define FALSE_ (0)
-
-/* Extern is for use with -E */
-#ifndef Extern
-#define Extern extern
-#endif
-
-/* I/O stuff */
-
-#ifdef f2c_i2
-/* for -i2 */
-typedef short flag;
-typedef short ftnlen;
-typedef short ftnint;
-#else
-typedef long int flag;
-typedef long int ftnlen;
-typedef long int ftnint;
-#endif
-
-/*external read, write*/
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
-
-/*internal read, write*/
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
-
-/*open*/
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
-
-/*close*/
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
-
-/*rewind, backspace, endfile*/
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
-
-/* inquire */
-typedef struct
-{ flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; /*parameters in standard's order*/
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
-} inlist;
-
-#define VOID void
-
-union Multitype { /* for multiple entry points */
- integer1 g;
- shortint h;
- integer i;
- /* longint j; */
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
-
-typedef union Multitype Multitype;
-
-/*typedef long int Long;*/ /* No longer used; formerly in Namelist */
-
-struct Vardesc { /* for Namelist */
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
-
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
-
-#define abs(x) ((x) >= 0 ? (x) : -(x))
-#define dabs(x) (doublereal)abs(x)
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#define dmin(a,b) (doublereal)min(a,b)
-#define dmax(a,b) (doublereal)max(a,b)
-#define bit_test(a,b) ((a) >> (b) & 1)
-#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
-#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
-
-/* procedure parameter types for -A and -C++ */
-
-#define F2C_proc_par_types 1
-#ifdef __cplusplus
-typedef int /* Unknown procedure type */ (*U_fp)(...);
-typedef shortint (*J_fp)(...);
-typedef integer (*I_fp)(...);
-typedef real (*R_fp)(...);
-typedef doublereal (*D_fp)(...), (*E_fp)(...);
-typedef /* Complex */ VOID (*C_fp)(...);
-typedef /* Double Complex */ VOID (*Z_fp)(...);
-typedef logical (*L_fp)(...);
-typedef shortlogical (*K_fp)(...);
-typedef /* Character */ VOID (*H_fp)(...);
-typedef /* Subroutine */ int (*S_fp)(...);
-#else
-typedef int /* Unknown procedure type */ (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef /* Complex */ VOID (*C_fp)();
-typedef /* Double Complex */ VOID (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef /* Character */ VOID (*H_fp)();
-typedef /* Subroutine */ int (*S_fp)();
-#endif
-/* E_fp is for real functions when -R is not specified */
-typedef VOID C_f; /* complex function */
-typedef VOID H_f; /* character function */
-typedef VOID Z_f; /* double complex function */
-typedef doublereal E_f; /* real function with -R not specified */
-
-/* undef any lower-case symbols that your C compiler predefines, e.g.: */
-
-#ifndef Skip_f2c_Undefs
-#undef cray
-#undef gcos
-#undef mc68010
-#undef mc68020
-#undef mips
-#undef pdp11
-#undef sgi
-#undef sparc
-#undef sun
-#undef sun2
-#undef sun3
-#undef sun4
-#undef u370
-#undef u3b
-#undef u3b2
-#undef u3b5
-#undef unix
-#undef vax
-#endif
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/f77_aloc.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/f77_aloc.c
deleted file mode 100644
index 1ff0f896b30..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/f77vers.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/f77vers.c
deleted file mode 100644
index 782d40160ca..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/fio.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/fio.h
deleted file mode 100644
index b16957a8fae..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/fio.h
+++ /dev/null
@@ -1,147 +0,0 @@
-#ifndef SYSDEP_H_INCLUDED
-#include "sysdep1.h"
-#endif
-#include <sys/types.h> /* for off_t */
-#include "stdio.h"
-#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 isatty(int);
-extern int err__fl(int,int,char*);
-extern int xrd_SL(void);
-extern int f__putbuf(int);
-#ifdef __cplusplus
- }
-#endif
-#endif
-extern int (*f__doend)(Void);
-extern FILE *f__cf; /*current file*/
-extern unit *f__curunit; /*current unit*/
-extern unit f__units[];
-#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
-#define errfl(f,m,s) return err__fl((int)f,m,s)
-
-/*Table sizes*/
-#define MXUNIT 100
-
-extern int f__recpos; /*position in current record*/
-extern OFF_T f__cursor; /* offset to move to */
-extern OFF_T f__hiwater; /* so TL doesn't confuse us */
-
-#define WRITE 1
-#define READ 2
-#define SEQ 3
-#define DIR 4
-#define FMT 5
-#define UNF 6
-#define EXT 7
-#define INT 8
-
-#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/fmt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/fmt.c
deleted file mode 100644
index 80bcd0a7663..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/fmt.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/fmt.h
deleted file mode 100644
index a2fdc651778..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/fmtlib.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/fmtlib.c
deleted file mode 100644
index 279f66f4390..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/fp.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/fp.h
deleted file mode 100644
index 40743d79f74..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/ftell64_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/ftell64_.c
deleted file mode 100644
index 9cc00cba8b9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/ftell_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/ftell_.c
deleted file mode 100644
index be9f2871086..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/getarg_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/getarg_.c
deleted file mode 100644
index 9006ad20169..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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<xargc)
- t = xargv[*n];
-else
- t = "";
-for(i = 0; i<ls && *t!='\0' ; ++i)
- *s++ = *t++;
-for( ; i<ls ; ++i)
- *s++ = ' ';
-}
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/getenv_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/getenv_.c
deleted file mode 100644
index 4c7ecd269ff..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/getenv_.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "f2c.h"
-#undef abs
-#ifdef KR_headers
-extern char *F77_aloc(), *getenv();
-#else
-#include <stdlib.h>
-#include <string.h>
-#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.17/libf2c/h_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_abs.c
deleted file mode 100644
index db6906869cf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_dim.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_dim.c
deleted file mode 100644
index 443427a9b99..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_dnnt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_dnnt.c
deleted file mode 100644
index 1ec641c5aa4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_indx.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_indx.c
deleted file mode 100644
index 018f2f43861..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_len.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_len.c
deleted file mode 100644
index 8b0aea99d26..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_mod.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_mod.c
deleted file mode 100644
index 611ef0aa8bf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_nint.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_nint.c
deleted file mode 100644
index 9e2282f2a74..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/h_sign.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/h_sign.c
deleted file mode 100644
index 4e214380cf9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/hl_ge.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_ge.c
deleted file mode 100644
index 8c72f03d489..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/hl_gt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_gt.c
deleted file mode 100644
index a448522db4b..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/hl_le.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_le.c
deleted file mode 100644
index 31cbc431a3f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/hl_lt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/hl_lt.c
deleted file mode 100644
index 7ad3c714b1d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i77vers.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i77vers.c
deleted file mode 100644
index 60cc24eec19..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_abs.c
deleted file mode 100644
index 2b92c4aa782..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_dim.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_dim.c
deleted file mode 100644
index 60ed4d8c5b4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_dnnt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_dnnt.c
deleted file mode 100644
index 3abc2dc4a51..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_indx.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_indx.c
deleted file mode 100644
index 19256393ecd..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_len.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_len.c
deleted file mode 100644
index 0f7b188d65a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_mod.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_mod.c
deleted file mode 100644
index 4a9b5609ba4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_nint.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_nint.c
deleted file mode 100644
index fe9fd68a86e..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/i_sign.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/i_sign.c
deleted file mode 100644
index 4c20e9494e1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/iargc_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/iargc_.c
deleted file mode 100644
index 2f29da0eaa6..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/iio.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/iio.c
deleted file mode 100644
index 8553efcf97f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/ilnw.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/ilnw.c
deleted file mode 100644
index e8b3d49cf1f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/inquire.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/inquire.c
deleted file mode 100644
index 5936a674ccc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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;i<MXUNIT;i++)
- if(f__units[i].ufd != NULL
- && f__units[i].ufnm != NULL
- && !strcmp(f__units[i].ufnm,buf)) {
- p = &f__units[i];
- break;
- }
-#else
- x=f__inode(buf, &n);
- for(i=0,p=NULL;i<MXUNIT;i++)
- if(f__units[i].uinode==x
- && f__units[i].ufd!=NULL
- && f__units[i].udev == n) {
- p = &f__units[i];
- break;
- }
-#endif
- }
- else
- {
- byfile=0;
- if(a->inunit<MXUNIT && a->inunit>=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.17/libf2c/l_ge.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/l_ge.c
deleted file mode 100644
index a84f0ee4abc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/l_gt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/l_gt.c
deleted file mode 100644
index ae6950d1391..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/l_le.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/l_le.c
deleted file mode 100644
index 625b49a9ea9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/l_lt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/l_lt.c
deleted file mode 100644
index ab21b362de9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/lbitbits.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/lbitbits.c
deleted file mode 100644
index 5b6ccf72d0a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/lbitshft.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/lbitshft.c
deleted file mode 100644
index fbee94f1403..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/lio.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/lio.h
deleted file mode 100644
index 012317206aa..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/lread.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/lread.c
deleted file mode 100644
index 55e068bf9fe..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/lread.c
+++ /dev/null
@@ -1,805 +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();
-#else
-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
-#endif
-#endif
-
- int
-t_getc(Void)
-{ int ch;
- if(f__curunit->uend) return(EOF);
- if((ch=getc(f__cf))!=EOF) return(ch);
- if(feof(f__cf))
- f__curunit->uend = l_eof = 1;
- return(EOF);
-}
-integer e_rsle(Void)
-{
- int ch;
- if(f__curunit->uend) return(0);
- while((ch=t_getc())!='\n')
- if (ch == EOF) {
- if(feof(f__cf))
- f__curunit->uend = l_eof = 1;
- return EOF;
- }
- return(0);
-}
-
-flag f__lquit;
-int f__lcount,f__ltype,nml_read;
-char *f__lchar;
-double f__lx,f__ly;
-#define ERR(x) if(n=(x)) return(n)
-#define GETC(x) (x=(*l_getc)())
-#define Ungetc(x,y) (*l_ungetc)(x,y)
-
- static int
-#ifdef KR_headers
-l_R(poststar, reqint) int poststar, reqint;
-#else
-l_R(int poststar, int reqint)
-#endif
-{
- char s[FMAX+EXPMAXDIGS+4];
- register int ch;
- register char *sp, *spe, *sp1;
- long e, exp;
- int havenum, havestar, se;
-
- if (!poststar) {
- if (f__lcount > 0)
- return(0);
- f__lcount = 1;
- }
-#ifdef Allow_TYQUAD
- f__llx = 0;
-#endif
- f__ltype = 0;
- exp = 0;
- havestar = 0;
-retry:
- sp1 = sp = s;
- spe = sp + FMAX;
- havenum = 0;
-
- switch(GETC(ch)) {
- case '-': *sp++ = ch; sp1++; spe++;
- case '+':
- GETC(ch);
- }
- while(ch == '0') {
- ++havenum;
- GETC(ch);
- }
- while(isdigit(ch)) {
- if (sp < spe) *sp++ = ch;
- else ++exp;
- GETC(ch);
- }
- if (ch == '*' && !poststar) {
- if (sp == sp1 || exp || *s == '-') {
- errfl(f__elist->cierr,112,"bad repetition count");
- }
- poststar = havestar = 1;
- *sp = 0;
- f__lcount = atoi(s);
- goto retry;
- }
- if (ch == '.') {
-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
- if (reqint)
- errfl(f__elist->cierr,115,"invalid integer");
-#endif
- GETC(ch);
- if (sp == sp1)
- while(ch == '0') {
- ++havenum;
- --exp;
- GETC(ch);
- }
- while(isdigit(ch)) {
- if (sp < spe)
- { *sp++ = ch; --exp; }
- GETC(ch);
- }
- }
- havenum += sp - sp1;
- se = 0;
- if (issign(ch))
- goto signonly;
- if (havenum && isexp(ch)) {
-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
- if (reqint)
- errfl(f__elist->cierr,115,"invalid integer");
-#endif
- GETC(ch);
- if (issign(ch)) {
-signonly:
- if (ch == '-') se = 1;
- GETC(ch);
- }
- if (!isdigit(ch)) {
-bad:
- errfl(f__elist->cierr,112,"exponent field");
- }
-
- e = ch - '0';
- while(isdigit(GETC(ch))) {
- e = 10*e + ch - '0';
- if (e > EXPMAX)
- goto bad;
- }
- if (se)
- exp -= e;
- else
- exp += e;
- }
- (void) Ungetc(ch, f__cf);
- if (sp > sp1) {
- ++havenum;
- while(*--sp == '0')
- ++exp;
- if (exp)
- sprintf(sp+1, "e%ld", exp);
- else
- sp[1] = 0;
- f__lx = atof(s);
-#ifdef Allow_TYQUAD
- if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
- /* Assuming 64-bit longint and 32-bit long. */
- if (exp < 0)
- sp += exp;
- if (sp1 <= sp) {
- f__llx = *sp1 - '0';
- while(++sp1 <= sp)
- f__llx = 10*f__llx + (*sp1 - '0');
- }
- while(--exp >= 0)
- f__llx *= 10;
- if (*s == '-')
- f__llx = -f__llx;
- }
-#endif
- }
- else
- f__lx = 0.;
- if (havenum)
- f__ltype = TYLONG;
- else
- switch(ch) {
- case ',':
- case '/':
- break;
- default:
- if (havestar && ( ch == ' '
- ||ch == '\t'
- ||ch == '\n'))
- break;
- if (nml_read > 1) {
- f__lquit = 2;
- return 0;
- }
- errfl(f__elist->cierr,112,"invalid number");
- }
- return 0;
- }
-
- static int
-#ifdef KR_headers
-rd_count(ch) register int ch;
-#else
-rd_count(register int ch)
-#endif
-{
- if (ch < '0' || ch > '9')
- return 1;
- f__lcount = ch - '0';
- while(GETC(ch) >= '0' && ch <= '9')
- f__lcount = 10*f__lcount + ch - '0';
- Ungetc(ch,f__cf);
- return f__lcount <= 0;
- }
-
- static int
-l_C(Void)
-{ int ch, nml_save;
- double lz;
- if(f__lcount>0) return(0);
- f__ltype=0;
- GETC(ch);
- if(ch!='(')
- {
- if (nml_read > 1 && (ch < '0' || ch > '9')) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
- if (rd_count(ch))
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"complex format");
- else
- err(f__elist->cierr,(EOF),"lread");
- if(GETC(ch)!='*')
- {
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"no star");
- else
- err(f__elist->cierr,(EOF),"lread");
- }
- if(GETC(ch)!='(')
- { Ungetc(ch,f__cf);
- return(0);
- }
- }
- else
- f__lcount = 1;
- while(iswhit(GETC(ch)));
- Ungetc(ch,f__cf);
- nml_save = nml_read;
- nml_read = 0;
- if (ch = l_R(1,0))
- return ch;
- if (!f__ltype)
- errfl(f__elist->cierr,112,"no real part");
- lz = f__lx;
- while(iswhit(GETC(ch)));
- if(ch!=',')
- { (void) Ungetc(ch,f__cf);
- errfl(f__elist->cierr,112,"no comma");
- }
- while(iswhit(GETC(ch)));
- (void) Ungetc(ch,f__cf);
- if (ch = l_R(1,0))
- return ch;
- if (!f__ltype)
- errfl(f__elist->cierr,112,"no imaginary part");
- while(iswhit(GETC(ch)));
- if(ch!=')') errfl(f__elist->cierr,112,"no )");
- f__ly = f__lx;
- f__lx = lz;
-#ifdef Allow_TYQUAD
- f__llx = 0;
-#endif
- nml_read = nml_save;
- return(0);
-}
-
- static char nmLbuf[256], *nmL_next;
- static int (*nmL_getc_save)(Void);
-#ifdef KR_headers
- static int (*nmL_ungetc_save)(/* int, FILE* */);
-#else
- static int (*nmL_ungetc_save)(int, FILE*);
-#endif
-
- static int
-nmL_getc(Void)
-{
- int rv;
- if (rv = *nmL_next++)
- return rv;
- l_getc = nmL_getc_save;
- l_ungetc = nmL_ungetc_save;
- return (*l_getc)();
- }
-
- static int
-#ifdef KR_headers
-nmL_ungetc(x, f) int x; FILE *f;
-#else
-nmL_ungetc(int x, FILE *f)
-#endif
-{
- f = f; /* banish non-use warning */
- return *--nmL_next = x;
- }
-
- static int
-#ifdef KR_headers
-Lfinish(ch, dot, rvp) int ch, dot, *rvp;
-#else
-Lfinish(int ch, int dot, int *rvp)
-#endif
-{
- char *s, *se;
- static char what[] = "namelist input";
-
- s = nmLbuf + 2;
- se = nmLbuf + sizeof(nmLbuf) - 1;
- *s++ = ch;
- while(!issep(GETC(ch)) && ch!=EOF) {
- if (s >= se) {
- nmLbuf_ovfl:
- return *rvp = err__fl(f__elist->cierr,131,what);
- }
- *s++ = ch;
- if (ch != '=')
- continue;
- if (dot)
- return *rvp = err__fl(f__elist->cierr,112,what);
- got_eq:
- *s = 0;
- nmL_getc_save = l_getc;
- l_getc = nmL_getc;
- nmL_ungetc_save = l_ungetc;
- l_ungetc = nmL_ungetc;
- nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
- *rvp = f__lcount = 0;
- return 1;
- }
- if (dot)
- goto done;
- for(;;) {
- if (s >= se)
- goto nmLbuf_ovfl;
- *s++ = ch;
- if (!isblnk(ch))
- break;
- if (GETC(ch) == EOF)
- goto done;
- }
- if (ch == '=')
- goto got_eq;
- done:
- Ungetc(ch, f__cf);
- return 0;
- }
-
- static int
-l_L(Void)
-{
- int ch, rv, sawdot;
-
- if(f__lcount>0)
- return(0);
- f__lcount = 1;
- f__ltype=0;
- GETC(ch);
- if(isdigit(ch))
- {
- rd_count(ch);
- if(GETC(ch)!='*')
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"no star");
- else
- err(f__elist->cierr,(EOF),"lread");
- GETC(ch);
- }
- sawdot = 0;
- if(ch == '.') {
- sawdot = 1;
- GETC(ch);
- }
- switch(ch)
- {
- case 't':
- case 'T':
- if (nml_read && Lfinish(ch, sawdot, &rv))
- return rv;
- f__lx=1;
- break;
- case 'f':
- case 'F':
- if (nml_read && Lfinish(ch, sawdot, &rv))
- return rv;
- f__lx=0;
- break;
- default:
- if(isblnk(ch) || issep(ch) || ch==EOF)
- { (void) Ungetc(ch,f__cf);
- return(0);
- }
- if (nml_read > 1) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
- errfl(f__elist->cierr,112,"logical");
- }
- f__ltype=TYLONG;
- while(!issep(GETC(ch)) && ch!=EOF);
- Ungetc(ch, f__cf);
- return(0);
-}
-
-#define BUFSIZE 128
-
- static int
-l_CHAR(Void)
-{ int ch,size,i;
- static char rafail[] = "realloc failure";
- char quote,*p;
- if(f__lcount>0) return(0);
- f__ltype=0;
- if(f__lchar!=NULL) free(f__lchar);
- size=BUFSIZE;
- p=f__lchar = (char *)malloc((unsigned int)size);
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,"no space");
-
- GETC(ch);
- if(isdigit(ch)) {
- /* allow Fortran 8x-style unquoted string... */
- /* either find a repetition count or the string */
- f__lcount = ch - '0';
- *p++ = ch;
- for(i = 1;;) {
- switch(GETC(ch)) {
- case '*':
- if (f__lcount == 0) {
- f__lcount = 1;
-#ifndef F8X_NML_ELIDE_QUOTES
- if (nml_read)
- goto no_quote;
-#endif
- goto noquote;
- }
- p = f__lchar;
- goto have_lcount;
- case ',':
- case ' ':
- case '\t':
- case '\n':
- case '/':
- Ungetc(ch,f__cf);
- /* no break */
- case EOF:
- f__lcount = 1;
- f__ltype = TYCHAR;
- return *p = 0;
- }
- if (!isdigit(ch)) {
- f__lcount = 1;
-#ifndef F8X_NML_ELIDE_QUOTES
- if (nml_read) {
- no_quote:
- errfl(f__elist->cierr,112,
- "undelimited character string");
- }
-#endif
- goto noquote;
- }
- *p++ = ch;
- f__lcount = 10*f__lcount + ch - '0';
- if (++i == size) {
- f__lchar = (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,rafail);
- p = f__lchar + i;
- }
- }
- }
- else (void) Ungetc(ch,f__cf);
- have_lcount:
- if(GETC(ch)=='\'' || ch=='"') quote=ch;
- else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
- Ungetc(ch,f__cf);
- return 0;
- }
-#ifndef F8X_NML_ELIDE_QUOTES
- else if (nml_read > 1) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
-#endif
- else {
- /* Fortran 8x-style unquoted string */
- *p++ = ch;
- for(i = 1;;) {
- switch(GETC(ch)) {
- case ',':
- case ' ':
- case '\t':
- case '\n':
- case '/':
- Ungetc(ch,f__cf);
- /* no break */
- case EOF:
- f__ltype = TYCHAR;
- return *p = 0;
- }
- noquote:
- *p++ = ch;
- if (++i == size) {
- f__lchar = (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,rafail);
- p = f__lchar + i;
- }
- }
- }
- f__ltype=TYCHAR;
- for(i=0;;)
- { while(GETC(ch)!=quote && ch!='\n'
- && ch!=EOF && ++i<size) *p++ = ch;
- if(i==size)
- {
- newone:
- f__lchar= (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,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(++i<size) *p++ = ch;
- else goto newone;
- }
- else if(GETC(ch)==quote)
- { if(++i<size) *p++ = ch;
- else goto newone;
- }
- else
- { (void) Ungetc(ch,f__cf);
- *p = 0;
- return(0);
- }
- }
-}
-
- int
-#ifdef KR_headers
-c_le(a) cilist *a;
-#else
-c_le(cilist *a)
-#endif
-{
- if(!f__init)
- f_init();
- f__fmtbuf="list io";
- f__curunit = &f__units[a->ciunit];
- 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.17/libf2c/lwrite.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/lwrite.c
deleted file mode 100644
index 9e0d93deb50..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/main.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/main.c
deleted file mode 100644
index 45397490471..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/open.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/open.c
deleted file mode 100644
index 49f739a3d7d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_ci.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ci.c
deleted file mode 100644
index 574e0b1ebac..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_dd.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_dd.c
deleted file mode 100644
index 08fc20884ae..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_di.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_di.c
deleted file mode 100644
index abf36cb74c0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_hh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_hh.c
deleted file mode 100644
index 882168501aa..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_ii.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ii.c
deleted file mode 100644
index 748d1217733..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_qq.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_qq.c
deleted file mode 100644
index 09fe18ec8e7..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_ri.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_ri.c
deleted file mode 100644
index e29d416eba2..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_zi.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_zi.c
deleted file mode 100644
index 1c0a4b07c2d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/pow_zz.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/pow_zz.c
deleted file mode 100644
index b5ffd334835..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/qbitbits.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/qbitbits.c
deleted file mode 100644
index ba1b5bd0c97..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/qbitshft.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/qbitshft.c
deleted file mode 100644
index 78e7b95100d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_abs.c
deleted file mode 100644
index f3291fb4d14..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_acos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_acos.c
deleted file mode 100644
index 103c7ff070b..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_asin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_asin.c
deleted file mode 100644
index 432b9406ac7..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_atan.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_atan.c
deleted file mode 100644
index 7656982db45..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_atn2.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_atn2.c
deleted file mode 100644
index ab957b89d54..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_cnjg.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cnjg.c
deleted file mode 100644
index cef0e4b092b..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_cos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cos.c
deleted file mode 100644
index 4418f0c1bbf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_cosh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_cosh.c
deleted file mode 100644
index f5478355809..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_dim.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_dim.c
deleted file mode 100644
index d573ca36d8d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_exp.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_exp.c
deleted file mode 100644
index 4e679794f22..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_imag.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_imag.c
deleted file mode 100644
index 1b4de14373a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_int.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_int.c
deleted file mode 100644
index bff87176ff6..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_lg10.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_lg10.c
deleted file mode 100644
index 64ffddf48b0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_log.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_log.c
deleted file mode 100644
index 94c79b05185..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_mod.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_mod.c
deleted file mode 100644
index 63ed1753689..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_nint.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_nint.c
deleted file mode 100644
index 7cc3f1b5aea..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_sign.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sign.c
deleted file mode 100644
index 797db1a4cbf..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_sin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sin.c
deleted file mode 100644
index 37e0df25fa5..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_sinh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sinh.c
deleted file mode 100644
index 39878f03ae7..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_sqrt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_sqrt.c
deleted file mode 100644
index e7b2c1c704a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_tan.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_tan.c
deleted file mode 100644
index 1774bed73a5..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/r_tanh.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/r_tanh.c
deleted file mode 100644
index 7739c6ce846..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/rawio.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rawio.h
deleted file mode 100644
index fd36a482602..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/rdfmt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rdfmt.c
deleted file mode 100644
index 62b28053409..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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;i++)
- { GET(ch);
- *p++=VAL(ch);
- }
- return(0);
-}
- static int
-#ifdef KR_headers
-rd_AW(p,w,len) char *p; ftnlen len;
-#else
-rd_AW(char *p, int w, ftnlen len)
-#endif
-{ int i,ch;
- if(w>=len)
- { for(i=0;i<w-len;i++)
- GET(ch);
- for(i=0;i<len;i++)
- { GET(ch);
- *p++=VAL(ch);
- }
- return(0);
- }
- for(i=0;i<w;i++)
- { GET(ch);
- *p++=VAL(ch);
- }
- for(i=0;i<len-w;i++) *p++=' ';
- return(0);
-}
- static int
-#ifdef KR_headers
-rd_H(n,s) char *s;
-#else
-rd_H(int n, char *s)
-#endif
-{ int i,ch;
- for(i=0;i<n;i++)
- if((ch=(*f__getn)())<0) return(ch);
- else *s++ = ch=='\n'?' ':ch;
- return(1);
-}
- static int
-#ifdef KR_headers
-rd_POS(s) char *s;
-#else
-rd_POS(char *s)
-#endif
-{ char quote;
- int ch;
- quote= *s++;
- for(;*s;s++)
- if(*s==quote && *(s+1)!=quote) break;
- else if((ch=(*f__getn)())<0) return(ch);
- else *s = ch=='\n'?' ':ch;
- return(1);
-}
-
- int
-#ifdef KR_headers
-rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
-#else
-rd_ed(struct syl *p, char *ptr, ftnlen len)
-#endif
-{ int ch;
- for(;f__cursor>0;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.17/libf2c/rewind.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rewind.c
deleted file mode 100644
index 9a0e07e6cfa..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/rsfe.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rsfe.c
deleted file mode 100644
index abe9724a7b8..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/rsli.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rsli.c
deleted file mode 100644
index 3d4ea428fc9..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/rsne.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/rsne.c
deleted file mode 100644
index f3fcfac13b1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/rsne.c
+++ /dev/null
@@ -1,616 +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
-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
-#endif
-#endif
-
- static Vardesc *
-#ifdef KR_headers
-hash(ht, s) hashtab *ht; register char *s;
-#else
-hash(hashtab *ht, register char *s)
-#endif
-{
- register int c, x;
- register hashentry *h;
- char *s0 = s;
-
- for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
- x += c;
- for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
- if (!strcmp(s0, h->name))
- return h->vd;
- return 0;
- }
-
- hashtab *
-#ifdef KR_headers
-mk_hashtab(nl) Namelist *nl;
-#else
-mk_hashtab(Namelist *nl)
-#endif
-{
- int nht, nv;
- hashtab *ht;
- Vardesc *v, **vd, **vde;
- hashentry *he;
-
- hashtab **x, **x0, *y;
- for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
- if (nl == y->nl)
- return y;
- if (n_nlcache >= MAX_NL_CACHE) {
- /* discard least recently used namelist hash table */
- y = *x0;
- free((char *)y->next);
- y->next = 0;
- }
- else
- n_nlcache++;
- nv = nl->nvars;
- if (nv >= 0x4000)
- nht = 0x7fff;
- else {
- for(nht = 1; nht < nv; nht <<= 1);
- nht += nht - 1;
- }
- ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
- + nv*sizeof(hashentry));
- if (!ht)
- return 0;
- he = (hashentry *)&ht->tab[nht];
- ht->nl = nl;
- ht->htsize = nht;
- ht->next = nl_cache;
- nl_cache = ht;
- memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
- vd = nl->vars;
- vde = vd + nv;
- while(vd < vde) {
- v = *vd++;
- if (!hash(ht, v->name)) {
- he->next = *zot;
- *zot = he;
- he->name = v->name;
- he->vd = v;
- he++;
- }
- }
- return ht;
- }
-
-static char Alpha[256], Alphanum[256];
-
- static VOID
-nl_init(Void) {
- register char *s;
- register int c;
-
- if(!f__init)
- f_init();
- for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
- Alpha[c]
- = Alphanum[c]
- = Alpha[c + 'a' - 'A']
- = Alphanum[c + 'a' - 'A']
- = c;
- for(s = "0123456789_"; c = *s++; )
- Alphanum[c] = c;
- }
-
-#define GETC(x) (x=(*l_getc)())
-#define Ungetc(x,y) (*l_ungetc)(x,y)
-
- static int
-#ifdef KR_headers
-getname(s, slen) register char *s; int slen;
-#else
-getname(register char *s, int slen)
-#endif
-{
- register char *se = s + slen - 1;
- register int ch;
-
- GETC(ch);
- if (!(*s++ = Alpha[ch & 0xff])) {
- if (ch != EOF)
- ch = 115;
- errfl(f__elist->cierr, ch, "namelist read");
- }
- while(*s = Alphanum[GETC(ch) & 0xff])
- if (s < se)
- s++;
- if (ch == EOF)
- err(f__elist->cierr, EOF, "namelist read");
- if (ch > ' ')
- Ungetc(ch,f__cf);
- return *s = 0;
- }
-
- static int
-#ifdef KR_headers
-getnum(chp, val) int *chp; ftnlen *val;
-#else
-getnum(int *chp, ftnlen *val)
-#endif
-{
- register int ch, sign;
- register ftnlen x;
-
- while(GETC(ch) <= ' ' && ch >= 0);
- if (ch == '-') {
- sign = 1;
- GETC(ch);
- }
- else {
- sign = 0;
- if (ch == '+')
- GETC(ch);
- }
- x = ch - '0';
- if (x < 0 || x > 9)
- return 115;
- while(GETC(ch) >= '0' && ch <= '9')
- x = 10*x + ch - '0';
- while(ch <= ' ' && ch >= 0)
- GETC(ch);
- if (ch == EOF)
- return EOF;
- *val = sign ? -x : x;
- *chp = ch;
- return 0;
- }
-
- static int
-#ifdef KR_headers
-getdimen(chp, d, delta, extent, x1)
- int *chp; dimen *d; ftnlen delta, extent, *x1;
-#else
-getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
-#endif
-{
- register int k;
- ftnlen x2, x3;
-
- if (k = getnum(chp, x1))
- return k;
- x3 = 1;
- if (*chp == ':') {
- if (k = getnum(chp, &x2))
- return k;
- x2 -= *x1;
- if (*chp == ':') {
- if (k = getnum(chp, &x3))
- return k;
- if (!x3)
- return 123;
- x2 /= x3;
- colonseen = 1;
- }
- if (x2 < 0 || x2 >= extent)
- return 123;
- d->extent = x2 + 1;
- }
- else
- d->extent = 1;
- d->curval = 0;
- d->delta = delta;
- d->stride = x3;
- return 0;
- }
-
-#ifndef No_Namelist_Questions
- static Void
-#ifdef KR_headers
-print_ne(a) cilist *a;
-#else
-print_ne(cilist *a)
-#endif
-{
- flag intext = f__external;
- int rpsave = f__recpos;
- FILE *cfsave = f__cf;
- unit *usave = f__curunit;
- cilist t;
- t = *a;
- t.ciunit = 6;
- s_wsne(&t);
- fflush(f__cf);
- f__external = intext;
- f__reading = 1;
- f__recpos = rpsave;
- f__cf = cfsave;
- f__curunit = usave;
- f__elist = a;
- }
-#endif
-
- static char where0[] = "namelist read start ";
-
- int
-#ifdef KR_headers
-x_rsne(a) cilist *a;
-#else
-x_rsne(cilist *a)
-#endif
-{
- int ch, got1, k, n, nd, quote, readall;
- Namelist *nl;
- static char where[] = "namelist read";
- char buf[64];
- hashtab *ht;
- Vardesc *v;
- dimen *dn, *dn0, *dn1;
- ftnlen *dims, *dims1;
- ftnlen b, b0, b1, ex, no, nomax, size, span;
- ftnint no1, no2, type;
- char *vaddr;
- long iva, ivae;
- dimen dimens[MAXDIM], substr;
-
- if (!Alpha['a'])
- nl_init();
- f__reading=1;
- f__formatted=1;
- got1 = 0;
- top:
- for(;;) switch(GETC(ch)) {
- case EOF:
- eof:
- err(a->ciend,(EOF),where0);
- case '&':
- case '$':
- goto have_amp;
-#ifndef No_Namelist_Questions
- case '?':
- print_ne(a);
- continue;
-#endif
- default:
- if (ch <= ' ' && ch >= 0)
- continue;
-#ifndef No_Namelist_Comments
- while(GETC(ch) != '\n')
- if (ch == EOF)
- goto eof;
-#else
- errfl(a->cierr, 115, where0);
-#endif
- }
- have_amp:
- if (ch = getname(buf,sizeof(buf)))
- return ch;
- nl = (Namelist *)a->cifmt;
- if (strcmp(buf, nl->name))
-#ifdef No_Bad_Namelist_Skip
- errfl(a->cierr, 118, where0);
-#else
- {
- fprintf(stderr,
- "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
- buf, nl->name);
- fflush(stderr);
- for(;;) switch(GETC(ch)) {
- case EOF:
- err(a->ciend, EOF, where0);
- case '/':
- case '&':
- case '$':
- if (f__external)
- e_rsle();
- else
- z_rnew();
- goto top;
- case '"':
- case '\'':
- quote = ch;
- more_quoted:
- while(GETC(ch) != quote)
- if (ch == EOF)
- err(a->ciend, EOF, where0);
- if (GETC(ch) == quote)
- goto more_quoted;
- Ungetc(ch,f__cf);
- default:
- continue;
- }
- }
-#endif
- ht = mk_hashtab(nl);
- if (!ht)
- errfl(f__elist->cierr, 113, where0);
- for(;;) {
- for(;;) switch(GETC(ch)) {
- case EOF:
- if (got1)
- return 0;
- err(a->ciend, EOF, where0);
- case '/':
- case '$':
- case '&':
- return 0;
- default:
- if (ch <= ' ' && ch >= 0 || ch == ',')
- continue;
- Ungetc(ch,f__cf);
- if (ch = getname(buf,sizeof(buf)))
- return ch;
- goto havename;
- }
- havename:
- v = hash(ht,buf);
- if (!v)
- errfl(a->cierr, 119, where);
- while(GETC(ch) <= ' ' && ch >= 0);
- vaddr = v->addr;
- type = v->type;
- if (type < 0) {
- size = -type;
- type = TYCHAR;
- }
- else
- size = f__typesize[type];
- ivae = size;
- iva = readall = 0;
- if (ch == '(' /*)*/ ) {
- dn = dimens;
- if (!(dims = v->dims)) {
- if (type != TYCHAR)
- errfl(a->cierr, 122, where);
- if (k = getdimen(&ch, dn, (ftnlen)size,
- (ftnlen)size, &b))
- errfl(a->cierr, k, where);
- if (ch != ')')
- errfl(a->cierr, 115, where);
- b1 = dn->extent;
- if (--b < 0 || b + b1 > size)
- return 124;
- iva += b;
- size = b1;
- while(GETC(ch) <= ' ' && ch >= 0);
- goto scalar;
- }
- nd = (int)dims[0];
- nomax = span = dims[1];
- ivae = iva + size*nomax;
- colonseen = 0;
- if (k = getdimen(&ch, dn, size, nomax, &b))
- errfl(a->cierr, k, where);
- no = dn->extent;
- b0 = dims[2];
- dims1 = dims += 3;
- ex = 1;
- for(n = 1; n++ < nd; dims++) {
- if (ch != ',')
- errfl(a->cierr, 115, where);
- dn1 = dn + 1;
- span /= *dims;
- if (k = getdimen(&ch, dn1, dn->delta**dims,
- span, &b1))
- errfl(a->cierr, k, where);
- ex *= *dims;
- b += b1*ex;
- no *= dn1->extent;
- dn = dn1;
- }
- if (ch != ')')
- errfl(a->cierr, 115, where);
- readall = 1 - colonseen;
- b -= b0;
- if (b < 0 || b >= nomax)
- errfl(a->cierr, 125, where);
- iva += size * b;
- dims = dims1;
- while(GETC(ch) <= ' ' && ch >= 0);
- no1 = 1;
- dn0 = dimens;
- if (type == TYCHAR && ch == '(' /*)*/) {
- if (k = getdimen(&ch, &substr, size, size, &b))
- errfl(a->cierr, k, where);
- if (ch != ')')
- errfl(a->cierr, 115, where);
- b1 = substr.extent;
- if (--b < 0 || b + b1 > size)
- return 124;
- iva += b;
- b0 = size;
- size = b1;
- while(GETC(ch) <= ' ' && ch >= 0);
- if (b1 < b0)
- goto delta_adj;
- }
- if (readall)
- goto delta_adj;
- for(; dn0 < dn; dn0++) {
- if (dn0->extent != *dims++ || dn0->stride != 1)
- break;
- no1 *= dn0->extent;
- }
- if (dn0 == dimens && dimens[0].stride == 1) {
- no1 = dimens[0].extent;
- dn0++;
- }
- delta_adj:
- ex = 0;
- for(dn1 = dn0; dn1 <= dn; dn1++)
- ex += (dn1->extent-1)
- * (dn1->delta *= dn1->stride);
- for(dn1 = dn; dn1 > dn0; dn1--) {
- ex -= (dn1->extent - 1) * dn1->delta;
- dn1->delta -= ex;
- }
- }
- else if (dims = v->dims) {
- no = no1 = dims[1];
- ivae = iva + no*size;
- }
- else
- scalar:
- no = no1 = 1;
- if (ch != '=')
- errfl(a->cierr, 115, where);
- got1 = nml_read = 1;
- f__lcount = 0;
- readloop:
- for(;;) {
- if (iva >= ivae || iva < 0) {
- f__lquit = 1;
- goto mustend;
- }
- else if (iva + no1*size > ivae)
- no1 = (ivae - iva)/size;
- f__lquit = 0;
- if (k = l_read(&no1, vaddr + iva, size, type))
- return k;
- if (f__lquit == 1)
- return 0;
- if (readall) {
- iva += dn0->delta;
- if (f__lcount > 0) {
- no2 = (ivae - iva)/size;
- if (no2 > f__lcount)
- no2 = f__lcount;
- if (k = l_read(&no2, vaddr + iva,
- size, type))
- return k;
- iva += no2 * dn0->delta;
- }
- }
- mustend:
- GETC(ch);
- if (readall)
- if (iva >= ivae)
- readall = 0;
- else for(;;) {
- switch(ch) {
- case ' ':
- case '\t':
- case '\n':
- GETC(ch);
- continue;
- }
- break;
- }
- if (ch == '/' || ch == '$' || ch == '&') {
- f__lquit = 1;
- return 0;
- }
- else if (f__lquit) {
- while(ch <= ' ' && ch >= 0)
- GETC(ch);
- Ungetc(ch,f__cf);
- if (!Alpha[ch & 0xff] && ch >= 0)
- errfl(a->cierr, 125, where);
- break;
- }
- Ungetc(ch,f__cf);
- if (readall && !Alpha[ch & 0xff])
- goto readloop;
- if ((no -= no1) <= 0)
- break;
- for(dn1 = dn0; dn1 <= dn; dn1++) {
- if (++dn1->curval < dn1->extent) {
- iva += dn1->delta;
- goto readloop;
- }
- dn1->curval = 0;
- }
- break;
- }
- }
- }
-
- integer
-#ifdef KR_headers
-s_rsne(a) cilist *a;
-#else
-s_rsne(cilist *a)
-#endif
-{
- extern int l_eof;
- int n;
-
- f__external=1;
- l_eof = 0;
- if(n = c_le(a))
- return n;
- if(f__curunit->uwrt && f__nowreading(f__curunit))
- err(a->cierr,errno,where0);
- l_getc = t_getc;
- l_ungetc = un_getc;
- f__doend = xrd_SL;
- n = x_rsne(a);
- nml_read = 0;
- if (n)
- return n;
- return e_rsle();
- }
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_cat.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_cat.c
deleted file mode 100644
index 5bf8a628ac0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/s_cmp.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_cmp.c
deleted file mode 100644
index 3a2ea67ddf0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/s_copy.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_copy.c
deleted file mode 100644
index 9dacfc7d8d2..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/s_paus.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_paus.c
deleted file mode 100644
index 51d80eb0878..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/s_rnge.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_rnge.c
deleted file mode 100644
index 5c12b949634..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/s_stop.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/s_stop.c
deleted file mode 100644
index 68233aea7e3..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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; i<n ; ++i)
- putc(*s++, stderr);
- fprintf(stderr, " statement executed\n");
- }
-#ifdef NO_ONEXIT
-f_exit();
-#endif
-exit(0);
-
-/* We cannot avoid (useless) compiler diagnostics here: */
-/* some compilers complain if there is no return statement, */
-/* and others complain that this one cannot be reached. */
-
-return 0; /* NOT REACHED */
-}
-#ifdef __cplusplus
-}
-#endif
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/sfe.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/sfe.c
deleted file mode 100644
index 21e1f044645..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/sfe.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/* sequential formatted external common routines*/
-#include "f2c.h"
-#include "fio.h"
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-extern char *f__fmtbuf;
-
-integer e_rsfe(Void)
-{ int n;
- n=en_fio();
- f__fmtbuf=NULL;
- return(n);
-}
-
- int
-#ifdef KR_headers
-c_sfe(a) cilist *a; /* check */
-#else
-c_sfe(cilist *a) /* check */
-#endif
-{ unit *p;
- f__curunit = p = &f__units[a->ciunit];
- 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.17/libf2c/sig_die.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/sig_die.c
deleted file mode 100644
index 8c22cd58113..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/signal1.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/signal1.h
deleted file mode 100644
index a383774b82d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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 <signal.h>
-
-#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.17/libf2c/signal_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/signal_.c
deleted file mode 100644
index 3b0e6cfe98b..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/signbit.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/signbit.c
deleted file mode 100644
index de95a3b70fd..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/sue.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/sue.c
deleted file mode 100644
index 191e32627cc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/sysdep1.h b/Build/source/utils/pmx/pmx-2.6.17/libf2c/sysdep1.h
deleted file mode 100644
index 4c026a240a1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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 <sys/types.h>
-#include <sys/stat.h>
-#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.17/libf2c/system_.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/system_.c
deleted file mode 100644
index 3220bfb5c2d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/typesize.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/typesize.c
deleted file mode 100644
index 39097f46991..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/uio.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/uio.c
deleted file mode 100644
index 44f768d9a24..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/uninit.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/uninit.c
deleted file mode 100644
index 794cd6adee0..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/uninit.c
+++ /dev/null
@@ -1,368 +0,0 @@
-#include <stdio.h>
-#include <string.h>
-#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 <stdlib.h>
-#include <stdio.h>
-#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 <alanb@chiark.greenend.org.uk> */
-/* 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 <alanb@chiark.greenend.org.uk> */
-
-#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 <machine/fpu.h>
- 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 <math.h>
-
-#ifndef FP_X_INV
-#include <fenv.h>
-#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 <fptrap.h>
-
- static void
-ieee0(Void)
-{
- fp_enable(TRP_INVALID);
- fp_trap(FP_TRAP_SYNC);
- }
-#endif /*_AIX*/
-
-#ifdef __sun
-#define IEEE0_done
-#include <ieeefp.h>
-
- 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.17/libf2c/util.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/util.c
deleted file mode 100644
index f4b3aef2ce7..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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<blen && *a!=0;i++) *b++= *a++;
- for(;i<blen;i++) *b++=' ';
-}
-#ifndef NON_UNIX_STDIO
-#ifdef KR_headers
-long f__inode(a, dev) char *a; int *dev;
-#else
-long f__inode(char *a, int *dev)
-#endif
-{ struct STAT_ST x;
- if(STAT(a,&x)<0) return(-1);
- *dev = x.st_dev;
- return(x.st_ino);
-}
-#endif
-#ifdef __cplusplus
-}
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.17/libf2c/wref.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/wref.c
deleted file mode 100644
index f2074b75e3a..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/libf2c/wref.c
+++ /dev/null
@@ -1,294 +0,0 @@
-#include "f2c.h"
-#include "fio.h"
-
-#ifndef KR_headers
-#undef abs
-#undef min
-#undef max
-#include "stdlib.h"
-#include "string.h"
-#endif
-
-#include "fmt.h"
-#include "fp.h"
-#ifndef VAX
-#include "ctype.h"
-#ifdef __cplusplus
-extern "C" {
-#endif
-#endif
-
- int
-#ifdef KR_headers
-wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
-#else
-wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
-#endif
-{
- char buf[FMAX+EXPMAXDIGS+4], *s, *se;
- int d1, delta, e1, i, sign, signspace;
- double dd;
-#ifdef WANT_LEAD_0
- int insert0 = 0;
-#endif
-#ifndef VAX
- int e0 = e;
-#endif
-
- if(e <= 0)
- e = 2;
- if(f__scale) {
- if(f__scale >= 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.17/libf2c/wrtfmt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/wrtfmt.c
deleted file mode 100644
index a970db95910..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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;i<w;i++) (*f__putn)('*');
- else
- { for(i=0;i<spare;i++) (*f__putn)(' ');
- if(sign) (*f__putn)('-');
- else if(f__cplus) (*f__putn)('+');
- for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
- }
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
-#else
-wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
-#endif
-{ int ndigit,sign,spare,i,xsign;
- longint x;
- char *ans;
- if(sizeof(integer)==len) 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);
- if(sign || f__cplus) xsign=1;
- else xsign=0;
- if(ndigit+xsign>w || m+xsign>w)
- { for(i=0;i<w;i++) (*f__putn)('*');
- return(0);
- }
- if(x==0 && m==0)
- { for(i=0;i<w;i++) (*f__putn)(' ');
- return(0);
- }
- if(ndigit>=m)
- spare=w-ndigit-xsign;
- else
- spare=w-m-xsign;
- for(i=0;i<spare;i++) (*f__putn)(' ');
- if(sign) (*f__putn)('-');
- else if(f__cplus) (*f__putn)('+');
- for(i=0;i<m-ndigit;i++) (*f__putn)('0');
- for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_AP(s) char *s;
-#else
-wrt_AP(char *s)
-#endif
-{ char quote;
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- quote = *s++;
- for(;*s;s++)
- { if(*s!=quote) (*f__putn)(*s);
- else if(*++s==quote) (*f__putn)(*s);
- else return(1);
- }
- return(1);
-}
- static int
-#ifdef KR_headers
-wrt_H(a,s) char *s;
-#else
-wrt_H(int a, char *s)
-#endif
-{
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- while(a--) (*f__putn)(*s++);
- return(1);
-}
-
- int
-#ifdef KR_headers
-wrt_L(n,len, sz) Uint *n; ftnlen sz;
-#else
-wrt_L(Uint *n, int len, ftnlen sz)
-#endif
-{ int i;
- long x;
- if(sizeof(long)==sz) x=n->il;
- else if(sz == sizeof(char)) x = n->ic;
- else x=n->is;
- for(i=0;i<len-1;i++)
- (*f__putn)(' ');
- if(x) (*f__putn)('T');
- else (*f__putn)('F');
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_A(p,len) char *p; ftnlen len;
-#else
-wrt_A(char *p, ftnlen len)
-#endif
-{
- while(len-- > 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;j<n;j++) (*f__putn)(' ');
- f__scale=oldscale;
- return(i);
- }
- return(wrt_E(p,w,d,e,len));
-}
-
- int
-#ifdef KR_headers
-w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
-#else
-w_ed(struct syl *p, char *ptr, ftnlen len)
-#endif
-{
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- switch(p->op)
- {
- 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.17/libf2c/wsfe.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/wsfe.c
deleted file mode 100644
index 8709f3b3479..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/wsle.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/wsle.c
deleted file mode 100644
index 3e602702c0c..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/wsne.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/wsne.c
deleted file mode 100644
index e204a51a4f1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/xwsne.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/xwsne.c
deleted file mode 100644
index f810d3edbfe..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_abs.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_abs.c
deleted file mode 100644
index 4d8a015d384..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_cos.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_cos.c
deleted file mode 100644
index 4abe8bf8820..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_div.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_div.c
deleted file mode 100644
index b61f03b8efc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_exp.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_exp.c
deleted file mode 100644
index 7b8edfece03..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_log.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_log.c
deleted file mode 100644
index 4f11bbe0c78..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_sin.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_sin.c
deleted file mode 100644
index 01225a9448d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/libf2c/z_sqrt.c b/Build/source/utils/pmx/pmx-2.6.17/libf2c/z_sqrt.c
deleted file mode 100644
index 35bd44c8e08..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/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.17/pmx2617.f b/Build/source/utils/pmx/pmx-2.6.17/pmx2617.f
deleted file mode 100644
index 09b5ec6e0dc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/pmx2617.f
+++ /dev/null
@@ -1,23597 +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 <http://www.gnu.org/licenses/>.
-c
-c
- character*9 date
- character*5 version,versionc
- common /comver/ versionc
-c
-c To compile with gfortran:
-c 1. Merge all files using copy *.for epmx[nnnn].for
-c 2. Search and replace all character*65536 with character*131072
-c 3. Comment/uncomment getarg lines
-c 4. gfortran -O pmx[nnnn].for -o pmxab.exe
-c
-c To do
-c Correct Rainer's email address in manual
-c Linesplit (\\) in h
-c Tt at start of a movement.
-c Toggle midi on or off; allow midi only.
-c Page number printed on 1st page even if 1 system.
-c Still need inserted space for chordal accidentals
-c Voicewise transposition.
-c better segno
-c coda
-c duevolte
-c Fix xtup bracket direction in 2-line staves?? (maybe leave as is)
-c Sticky ornaments with shifts.
-c Deal with Werner's vertical spacing thing associated with title.
-c Multiple ties in midi
-c Werner's missing c in MIDI due to start/stop ties on same note.
-c Beams with single 64ths
-c 128ths and/or dotted 64ths
-c Close out MIDI with integral # of beats?
-c Increase ast dimensions or redo logic.
-c Does slur direction get set for user-defined single-note stem dir'ns?
-c Transpose by sections.
-c Optimization loop over sections only
-c Command-line option to read nbarss in. Write out nbarss when optimizing.
-c (or just read from .plg?)
-c Beams over bar lines.
-c 2-digit figures
-c A real coule (slanted line between notes in a chord)
-c Dotted slurs for grace notes.
-c Undotted chord notes with dotted main note.
-c Forced line break without line number
-c Fix dot moving when 2nds in chord get flipped
-c To do: increase length on notexq in dodyn
-c 2.617
-c In g1etnote, change if-check for note to use index(...) instead
-c of ichar(charq) since it was messing up gfortran optimizer
-c After pmxa, search for and remove penultimate line <blank><blank>/
-c because it was screwing up linux-compiled versions
-c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...)
-c 2.616 (111110)
-c Allow hairpins to span multiple notes groups (gulps).
-c 2.615+ (110810)
-c Fix midi when some instruments are transposed, by subtracting
-c iTransAmt(instno(iv)) from pitch values sent to via addmidi in
-c make2bar.for (for main notes) and docrd (for chord notes)
-c 2.615 (110725)
-c Fig bug with size-setting (in topfile) when instrument has >1 staves
-c 2.615 (110724)
-c Make AS[0|-|s|t]... really set sizes
-c 2.614
-c Mod notex.for to fix Terry's bug with raised dotted rests (caused
-c by double-hboxing).
-c 2.613
-c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno.
-c 2.612
-c Enhance AS to allow s or t for smallsize or tinysize
-c 2.611
-c Error trap for "D" before any notes in a block.
-c 2.610
-c Instrument-wise key changes and transposition (incomplete)
-c 2.603
-c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors
-c following reading in an include file.
-c 101121 Added some error messages in g1etset.for setup data
-c 2.602
-c Correct slur indexing in linebreakslurs.
-c Account for comment lines in line count for error messages
-c 2.601
-c Bug fix: allow 24 slurs with graces
-c 2.60 Changes made make it really big
-c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o
-c major reprogramming, and 16 may also be a problem (icmm)
-c nm=24 (voices) done
-c 24 slurs done
-c 24 simultaneous beams (Replace index 24 by 0, so get 0-23)
-c bufq*131072 (gfortran only)
-c getarg syntax (gfortran only)
-c 2.523+
-c Fix voice numbering for normal dynamics and text dynamics
-c 2.523
-c Version of bigpmx first posted to Hiroaki's web site.
-c 2.522
-c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it.
-c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices.
-c 5/13/10 Fix log2 function
-c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length.
-c 2.521+
-c 091025 Enable dotting 2nd part of linebreak slur or tie.
-c To adjust barno height due to linebreak slur, use \bnrs instead of
-c explicitly redefining \raisebarno (pmxb)
-c 2.521
-c Bugfix
-c 2.520
-c 090519 Enable ligfonts (special figured bass characters)
-c 2.519
-c Fix another bug which kept \sk from being output so misaligned some notes.
-c 2.518
-c Fix bugs: referencing fig data, char declaration for member of
-c common/comfig/
-c 2.517
-c Allow figures in voice 1 + any one other.
-c 2.516
-c Allow figures in voice #2
-c 2.515+ to do: Change manual and activate rule against clef change in voice #2.
-c 2.515
-c 071222 Changes in getnote to allow auto forced beams to start anywhere.
-c 071206 In make2bar, shift fermataup7 to left over centered pause.
-c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line
-c staff (it was screwing up vertical justification).
-c n34 for tweaks to midi durations of quarter note septuplets.
-c To do: In ref250.tex, the tables where 's,t,)' is explained, the line
-c [+,- i] ... Vertical adjustment of the start of second segment
-c should it be replaced by
-c [s +,- i] ... Vertical adjustment of the start of second segment
-c 2.514
-c Changes in make2bar to get horizontal spacing right when normal grace
-c follows after grace
-c Changes in dograce to get octaves right for any material entered inside
-c \gaft, which shields transpose register changes from the outside world.
-c 2.513
-c In make1bar, near end, for forced beams starting with a rest, copy hgt and
-c slope tweaks to ALL notes after first, not just the second one, so if
-c there's more than one rest at start the tweaks are still observed.
-c In beamid and beamend, add stand-alone triply-flagged notes for xtups.
-c 2.512
-c Near end of pmxb, fix error trap to allow redundant 'RD'
-c Enable multiplicity down-up '][' within xtup.
-c 2.511
-c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by
-c adjusteskz as in bar 7 of barsant.
-c 2.510a
-c Test: remove restriction on tempo changes in MIDI macros
-c Send to CM for beta testing.
-c 2.509+
-c To do: Correct manual on AS. "-" is for smaller staves.
-c 2.510
-c Forgot to declare litq, voltxtq as character in subroutine getgrace
-c 2.509
-c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp)
-c 2.508
-c Allow graces in xtups. New subroutine getgrace.
-c 2.507
-c To do: Raise/lower figures.
-c To do: Add 24, 29 to list of musicsizes in manual
-c New sub adjusteskz to account for ask's when computing lengths of
-c brackets for unbeamed xtups, slopes and horizontal posn's of number
-c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags
-c Add look-left option for keyboard rests, "L" in rest command, set iornq(30)
-c 2.506
-c Fix bug with AK, when simultaneous rests have same duration, use defaults.
-c 2.505
-c Keyboard rests AK
-c 2.504
-c Space after normal grace: option X[n]
-c Fixed og when nv .ne. noinst, by using sepsymq instead of '&'
-c (To do) length of xtup bracket when there is added non-collision space.
-c Trap musicsize if .ne. 16,20,24,29.
-c 2.503
-c Enable arpeggio left shift with ?-x
-c To do: In manual, arpeggio over 2 staves.
-c Allow musicsize of 24 and 29. Had to define meter font size explicitly,
-c also change font size for text dynamics, but not much else so far.
-c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn
-c was called, causing error in printing replacement number.
-c 2.502
-c Incorporate Dirk Laurie's patch to use { , } , for ties.
-c Figure height adjustment: append +[n]
-c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?)
-c 2.501
-c Readjust horizontal offset back to .8 in LineBreakTies
-c Fix zero-subscript (iudorn) in putorn
-c 2.50
-c Increase number of text-dynamics (dimension of txtdynq) per block
-c from 12 to 41.
-c Slur option n to override altered default curvature.
-c Allow default ps slur curvature tweaks with Ap+/-c
-c 2.416
-c Increase length of textdynq from 24 to 128
-c (Todo) Add comment in manual about blank lines at end.
-c Configuration file: Define subroutine getpmxmod, check path in environment
-c variable pmxmoddir, check existence, read lines into bufq after setup.
-c Increase dimension on idynn in dodyn from 4 to 10 for max number
-c of marks in a bar
-c Increase allowable # of lines from 2000 to 4000.
-c (To do) Replace definition of \liftpausc per Olivier.
-c (To do) Fix extraneous error message if RD is placed at very end.
-c 2.415
-c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt
-c instead of redefining \xnum. Change font used to \smallfont (as for
-c normal xtups,
-c Allow slur to start on rest.
-c 2.414
-c Correct bug in crdacc when adding accidental to boundary causes number of
-c segments to decrease
-c Special rule for 3-accidental chords: If no 2nds, place them in order
-c top, bottom, middle.
-c 2.413
-c Correct bugs in chordal accidentals, related to left-shifted noteheads
-c (a) Special problems with downstem when main note needs shifting
-c (b) Assign 0 rank to boundary segs due to left-shifted noteheads
-c 2.412
-c Change default horiz shift of start of seg 2 of linebreak slurs:
-c -.7 for slurs, -1.2 for ties,
-c Use height of start of seg 1 slur itself for end of 1 and start of 2.
-c 2.411
-c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2.
-c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end
-c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2.
-c With "Apl", curvature adjustments on starting slur command apply to seg 1,
-c those on ending command to seg 2.
-c 2.410
-c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine
-c \xnum, \unbkt, \ovbkt.
-c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is
-c flag, mult(5-9) is tweak value+16
-c 2.409
-c Bugfix in docrd for MIDI: Use original pitch in case main/chord were
-c switched due to 2nds.
-c Remove "o" from error message for "A" command.
-c New syntax: optional instrument number separator ":" in movement
-c break command to precede a 2-digit instrument.
-c Conditional output formats for \setname at movement break to allow
-c instrument numbers >9.
-c Bugfix in coding to raise barno due to slur over line break (pmxb)
-c Move date/version data statement in pmxab to a better place.
-c 2.408
-c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar).
-c Bug fix in \liftPAusep in notex.for and in pmx.tex
-c Character variables for version and date
-c For up-stem single graces slurred to down-stem, shift slur start left by
-c 0.8 so slur doesn't get too short.
-c Initialize and slide mult, same as other full-program variables in /all/.
-c 2.407
-c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n,
-c 2.406
-c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing
-c equalization).
-c Put dimensions of double sharps and flats in crdacc (for chords).
-c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&'
-c Use only first 4 bits of mult for multiplicity+8, so rest can be used
-c for other stuff.
-c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict.
-c 2.405: Not published but saved for safety.
-c Option Aph to write \special{header=psslurs.pro} top of each page, so
-c dviselec will work OK.
-c 2.404
-c Allow slur to end on rest, but not start on a rest. Efaults height
-c of ending is default height of start (before any automatic or user-
-c defined djustments). User may adjust height as normal from default.
-c 2.403
-c Bugfix: turn off repeated beaming patterns.at end of non-last voice.
-c 2.402
-c Automatic repeated forced beams. Start with "[:" End with next explicit
-c forced beam or end of input block.
-c Increase # of forced beams per line of music per input block from 20 to 40
-c 2.401
-c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies.
-c Makes 1st part normal shape, and starts 2nd part a little further left.
-c Enable arpeggios in xtuplets. Had to make time itar(narp) a real.
-c 2.40
-c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap.
-c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse
-c sign for down-slurs.
-c 2.359
-c Add error exit subroutine stop1 to make exit status g77-compatible..
-c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote
-c Fermata on vertically shifted rest: special trap in putorn() to set height.
-c Correct multiple grace note spacing for small staves (in dograce,
-c define wheadpt1 depending on staff size)
-c 2.358
-c Allow curvature corrections at start of postscript slur, in dopsslur()
-c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust
-c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h]
-c Make t[ID] act like s[ID]t, most mods in spsslur().
-c Add spsslur() to read in data for ps slurs, call from getnote.
-c In beamstrt, save args for SetupB in common comipb to save them for
-c 2nd call when xtup starts with rest
-c Add spacing for ornament ")" as if it were accidental, in make2bar().
-c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur()
-c Horiz. shift start of ps grace slur, 2 places in dograce().
-c Horiz shift end of grace slur in endslur()
-c Make st slurs into postscript ties. Separate subroutine dopsslur(),
-c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.)
-c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn.
-c 2.357a
-c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote
-c 2.357
-c Increase dimension for # of lit TeX strings from 52 to 83.
-c Allow blank rest in middle of xtuplet. Only mods in g*etnote().
-c 2.356
-c Increased some dimensions from 30 to 40 to allow up to 40 pages.
-c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt().
-c Fix parsing of "f,h,H,HH" in sslur.
-c Fix bug with cdot, note-level for slur termination (in getnote)
-c 2.355
-c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)],
-c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues
-c Make midi recognize ps ties in doslur.
-c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote
-c to get octave right.
-c 2.354
-c With postscript slurs, make t-slurs real ties by inserting replacement
-c macros \tieforisu, etc, defined in pmx.tex
-c Check for open cresc or decresc at end of input block, using list[de]cresc
-c Hairpin syntax conditional on postscript slurs. Backup to fill in start
-c level, using new backfill(...). Separate height tweaks for
-c start and finish.
-c 2.353
-c K-0+n to transpose by half step (rather than just change key)
-c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of
-c \mbrest's
-c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end
-c of input block before movement break, and at start of block after
-c movement break, using \newmovement rather than \setzalaligne, since
-c former already redefines \stoppiece. In second case, set rptfg2='z'.
-c Make clefq(nm) common between pmxb and getnote; change references in
-c getnote at 'M' to array elements, setting all new clefs as you go.
-c 2.352
-c Remove \parskip redefinition from pmx.tex; write it into TeX file when
-c "Ae" is invoked.
-c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine
-c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH',
-c translate them thru mapping to (1,4,5,6) as \midslur params, then let
-c \psforts translate them back to ps slur macors.
-c 2.351
-c Number slurs from 0 up instead of 11 down, anticipating postscript slurs.
-c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size.
-c Increase length of basenameq to 44 characters everywhere.
-c Increase dimension of mcpitch (midi-chord-pitch) to 20.
-c Set default systems per page to 1 if nv>7
-c In pmxb, move place where isystpg is reset to 0, so that \eject gets
-c written when there is just one system per page.
-c 2.35
-c Cautionary accidentals with 'c' anywhere in note symbol.
-c NEW pmx.tex with \resetsize to set size to normal or small depending on
-c current \internote. Used with new coding in dograce() to get right
-c new size in case user has \setsize'ed some lines to \smallvalue. For
-c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font.
-c Affects pmx.tex.
-c Continuation figure with fractional length. May now mix with other figures.
-c If another figure follow Cont-fig, separate with colon.
-c 2.342
-c Bugfix in getnote to recognize relative octave shift in grace at start of
-c input block.
-c In make2bar, initialize islhgt=0 earlier than before (possible solution
-c to Suse g77 compile problem that I could not reproduce)..
-c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d
-c 2.341
-c Syntax check: Forced page break page number must be > than previous.
-c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb.
-c 2.34
-c New pmx.tex with redefined liftpausc
-c Bug fix with dotted, non-beamed xtups.
-c 2.332
-c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads.
-c Allow arbitrary pos. input to W in g1etnote and getnote.
-c 2.331
-c Bug-fix in dodyn(..): typo on length of arg of txtdyn
-c 2.33
-c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata()
-c 2.321
-c Rescale accidental shifts. Still use 7 bits but now map (0,127)
-c onto (-1.,5.35)
-c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups
-c 2.32 (Noticed after posting)
-c Prohibit "/" as figure.
-c 2.32 (Posted)
-c Tidied up accidentals in chords, do spacing.
-c Still to do:
-c check for "(" on chord notes in spacing algo
-c small accids
-c double accids
-c autoshift slurs
-c 2.310
-c Extra call to precrd ahead of spacing chk, and single-note crd/acc
-c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time.
-c 2.309
-c Alternate algo for accid shifts in chords.
-c 2.308
-c Auto horiz. notehead shifting added to precrd.
-c 2.307
-c Auto shifting of multiple accidentals in chords.
-c "Ao" in main chord note to keep accidentals in order. Set nacc(28).
-c If there are any manual main or chord note shifts, then
-c If any manual shift is preceded by "A" then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts,
-c End if
-c End if
-c 2.306
-c Initialize legacy note level to middle C in case user forgets to set
-c octave.
-c Shift xtup note?
-c Shift in elemskips rather than noteheads?
-c 2.305
-c Stop pmxb from multiple endvolta's at start of new page.
-c 2.304
-c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on
-c for multiple notes in the voice, "S:" last shortened note.
-c 2.303
-c vshrink stuff all OK? Description is in pmxb.
-c 2.302
-c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff
-c hits 20. This still needs work.
-c Add " /" to last line if last char is not % or /.
-c 2.301
-c Check in beamn1 for single note before multiplicity down-up.
-c allow '.PMX' as well as '.pmx'
-c 2.299
-c Correct typo in pmxb involving PMXbarnotrue.
-c Replacement printed number for xtup: Unsigned integer after 'n' after 'x'
-c Minor upgrade parsing xtuplet options 'x...'
-c Correct dimension of nxtinbm in make2bar.
-c 2.298
-c Account for doubled xtup notes in subroutine getx (user-defined spaces),
-c by adding ndoub as an argument..
-c 2.297
-c Created and solved compiler problem. Put drawbm(NM) in its own common.
-c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar
-c when \centerbar is used.
-c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX
-c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes.
-c 2.296
-c Correct printed numbers for forced beams with multiple xtups. For each beam
-c make list in setupb by voice of eloff (h-offset) and mtupv (printed #)
-c Increase lengths of jobname and infileq by 20 characters
-c Enable whole notes and breves as 1st or last note of xtup in beamn1 and
-c beamend, and wholes in beamid.
-c 2.295
-c Midi balance Ib[n1]:[n2]:...[nn]
-c Single-slope beam groups [...]-[...]
-c Trap "i" unless after accidental (main notes, xtups, chord notes)
-c 2.294
-c Unequal xtups with "D" to double a note in an xtup.
-c As above, "F" will (a) increase multiplicity by 1 for marked note and next
-c one and (b) add a dot to the first one.
-c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on
-c when "." is encountered, then correcting beam start time.(end of getnote)
-c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]...
-c 2.293
-c Check for single notes spanning bar lines.
-c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup
-c must be set in make2bar since beamstrt is not called, fixing problem with
-c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix
-c problem when >2 staves.
-c Add nodur to args of dodyn, so can check if stemless and avoid height tweak
-c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak
-c 2.292a
-c Undo syntax check for Type 2 or 3 TeX string starting in column 1.
-c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?!
-c 2.292
-c Allow comments in xtuplets
-c Enable multiple octave jumps in grace notes.
-c Allow dynamics in xtuplets.
-c Fix bug in getdyn searching for end of text string (correct length of lineq
-c to 128)
-c Fix bug in dodyn, must ignore horiz. interaction tweak for
-c user-text (idno = 0)
-c Syntax check for Type 2 or 3 TeX string starting in column 1
-c (NOTE: later undone!)
-c Syntax check for page number > npages at forced line break.
-c 2.291
-c Fix error in AS command (accid spacing for small systems), making only
-c one spec per staff, nv total.
-c Stop using MIDI channel 10
-c 2.29
-c Fix error in console output format for # of bytes used in MIDI file.
-c Fix bug in dograce so no space is added between grace and main note when
-c there is a MIDI-only accidental.
-c Fix bug so oes?+4 works. It was too ugly to explain.
-c ...Different ways of storing accidental specs on input and output.
-c No longer zap \writezbarno in special situations.
-c Fix bug in dyntxt level on rest
-c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc.
-c Activate with Ae. (Maybe later could input alternate values for
-c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1
-c in the page, and \endeq on 1st note of next-to-last line in page.
-c 2.28
-c Flip direction of forced beam "[f..."
-c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30)
-c Fix bug in sliding ip's for txtdyn's
-c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99)
-c 2.27
-c Comment out lines in dodyn checking number of dynamic marks found. Voice
-c order may not be monotonic if two lines on a staff.
-c Literal dynamic: D"[text]"
-c 2.26
-c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn,
-c increasing dimension of idynn to 4 to allow 4 symbols on same note.
-c Increase voltxtq length from 10 to 20.
-c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough
-c accounting for ast's is done by defining effective headwidth
-c whead1 in makebar2 to be 0.8*whead.
-c 2.25
-c Fix logic bug with sepsym's when # of instruments changes.
-c Slight increases in default offsets for hairpin starts after "p"
-c 2.24
-c Hairpins D< or D> as toggle.
-c Many automatic position tweaks for letter-group dynamics and hairpins.
-c 2.23
-c Continued rhythmic shortcuts: space followed by "." or ","
-c 2.22
-c In call to doslur, change tno(...) to tnote(...). This was only
-c used when checking to slurs per stem directions, and should have been
-c the note duration all along.
-c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat.
-c Use "i" anywhere in note symbol.
-c 2.21
-c Increase from 20 to 30 dimensions for movement breaks and midi sections.
-c Fix out-of-order declarations per mutex comments
-c Add "Bad error" and "Kluging" messages to log file.
-c 2.197
-c add /comips/ to save tie-check midi variables
-c For spacing of clef changes at start of input block, changed integer time
-c lastnodur to prevtn, so it works with xtups. Possible incompatibility!
-c 2.196
-c Fix Ickbug with time check in ncmid()
-c Interchange \fermataup7 and \pausec to get proper alignment
-c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX.
-c Add defn's of \hsp, \hspp to pmx.tex
-c Fix pre-slurs on xtup chord notes.
-c Fixed raised PAuse, define \liftPAuse
-c Replace \zbreve\sk with \breve.
-c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what
-c about "o" and 1 as shorthand for 16???? Search for "Kluge"
-c Added "vo" (voice) as MIDI instrument 55
-c Allow 3-digit page numbers (search for "toppageno")
-c Fix bug caused by prior fix (cancelling accid after bar line was ignored).
-c Fix double accids in chords
-c 2.194
-c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if
-c block.
-c Add meter to MIDI file with every pause
-c Purify FORTRAN?
-c 2.193
-c Increased # of in-line TeX strings from 36 to 52.
-c Fix entry of # of bytes in header of tempo/meter/key track to allow >255.
-c 2.191
-c Event track: Tempos, meters, keys all together. Data in comevent
-c 2.15
-c Pretty good midi capability. Still no attention to slurs on chord notes.
-c 2.11
-c 11 Dec 99 c rm1
-c 11 Dec 99 "oes?", "oe?"
-c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes
-c 11 Dec 99 Error message for shifted, repeated ornaments.
-c 2.10 (Version 2.1)
-c Fix bug with lowdot and xtuplets
-c 2.09
-c Fix bug with multiple ornament heights over beams, when one is . or _
-c Error message from pmxa if rest on last note of xtup.
-c Enable 12 slurs.
-c Reinstate multiple rests at start of xtup.
-c 2.07
-c Combine consecutive type-1 TeX strings.
-c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's.
-c Fixed breve chord notes in docrd
-c Check irest(28) as well as vxtup when setting nodur for chord notes, since
-c vxtup isn't set until 1st *main* note in xtup
-c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing.
-c 2.06+
-c Make deterministic the beam slope calculation when there are an even # of
-c slopes in list and middle two are equal magnitude but opposite sign.
-c pmxa Trap for "o:" before 1st note in block
-c Partial bug fix for 64th notes in xtuplets.
-c Make ixrest a vector, since with new time scheme may not finish xtup in
-c same notes block.
-c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb)
-c 2.06
-c Account for changes in nv when computing \interstaff. Add a counter
-c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever
-c setting isysflb(iflb). Note nv can only change at a forced line break.
-c Note also, iflb starts at 0!
-c 2.05
-c Automatic start of new notes group with part 2 of staff-jump beam
-c In make1bar, set irest bit 29 of lowest-voice note at same time,
-c use as flag when making notes groups.
-c For now, remove dummy blank line at end...it zaps terminal repeats.
-c 2.02
-c Fixed slur-counting bug for multiple, slurred, aftergraces.
-c 2.01
-c Increase to ask(1400)
-c Increase max forced page breaks to 18
-c Define pausc for centered pause
-c 2.0a
-c Insert dummy blank line at very end to handle input files w/o terminal CR-LF
-c pmx03r
-c Option m[n] in S symbol to change musicsize (for parts)
-c Double dotted rests now work.
-c Write file name to log file
-c Check existence of input file
-c Allow 24-char jobname, may end with ".pmx"
-c Comment out time stuff
-c Replace 3-argument getarg with 2-argument + iargc
-c Fix bug with negative noinst due to nint<=int replacement
-c move lovation of iv in isdat1 to allow iv>7.
-c Set nm=12
-c pmx03q
-c replace int(x+.001) with nint(x)
-c Write TeX file name to screen and to pml.
-c Replace char(...) with chax(...) to sovle msdev bug.
-c Bug fix: macro terminations when M is on a line by itself.
-c Bug fix: don't accumulate space for XS in pmxa.
-c Streamline Macros: use pointers to bufq instead of scratch files
-c pmx03p
-c Store input file in single character array bufq.
-c lbuf(i)*2 is length of line i
-c ipbuf is position just before next line to be read.
-c pmx03
-c Optimize read/writes
-c pmx02
-c Fix line count (for errors) when there are saved macros
-c pmx01
-c In optimize mode, open/close macros (Watch out for residual zz files!)
-c Command line input
-c Option Ao to optimize, otherwise normal processing
-c
-ccccccc
- parameter (nks=125,nm=24,mv=24576,maxblks=4000)
- character*128 lnholdq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /comevent/ miditime,lasttime
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- common /commus/ musize,whead20
- integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks)
- real*4 poe0(nks),poe(nks)
- logical isfirst,optimize
- logical*4 fexist
- character*44 jobname
- character*47 infileq
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * idum,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- logical rest,firstline,newmeter
- common /comdiag/ n69(0:nm),n34(0:nm)
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- common /truelinecount/ linewcom(20000)
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
-ccccccccccccccccccccccccc
-c
- data date /'28 Jan 12'/
- data version /'2617'/
-c
-ccccccccccccccccccccccccc
- data maxit,ncalls /200,0/
- data isfirst /.true./
-c itstart = mytime()
- versionc = version
-c
-c Initialize midi parameters
-c
- gottempo = .false.
- ismidi = .false.
- debugmidi = .false.
- relacc = .false.
- mmacrec = .false.
- nmidsec = 1
- mgap = 10
- miditime = 0
- lasttime = 0
- nmidcrd = 0
- nusebl = 0
- notmain = .false.
- do 3 ivx = 1 , nm
- twoline(ivx) = .false.
- midinst(ivx) = 6
- midivel(ivx) = 127
- midibal(ivx) = 64
- miditran(ivx) = 0
-3 continue
- do 12 icm = 0 , nm
- imidi(icm) = 0
- restpend(icm) = .false.
- trest(icm) = 0.
- levson(icm) = 0
- levsoff(icm) = 0
- slmon(icm) = .false.
- naccbl(icm) = 0
- n69(icm) = 0
- n34(icm) = 0
- msecstrt(icm,1) = 1
-12 continue
-c
-c End of midi parameter initialization
-c
- musize = 0
- optimize = .false.
- numargs = iargc()
- if (numargs .eq. 0) then
- print*,'You could have entered a jobname on the command line,'
- print*,' but you may enter one now:'
- read(*,'(a)')jobname
- numargs = 1
- else
-c call getarg(1,jobname,idum) ! May need to replace this w/ next line
- call getarg(1,jobname)
- end if
-10 ljob = lenstr(jobname,44)
- if (ljob .gt. 44) then
- print*,'Jobname is too long. Try again.'
- call stop1()
- else if (ljob .eq. 0) then
- print*,'No was jobname entered. Try again.'
- call stop1()
- else if (numargs .eq. 2) then
- if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then
- optimize = .true.
-c call getarg(2,jobname,idum) ! May need to replace this w/ next line
- call getarg(2,jobname)
- numargs = 1
- go to 10
- else
- print*,'Illegal option on command line'
- call stop1()
- end if
- end if
-c
-c Strip ".pmx" if necessary
-c
- ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
- if (ndxpmx .gt. 0) then
- jobname = jobname(1:ndxpmx-1)
- ljob = ljob-4
- end if
-c
-c Check for existence of input file
-c
- infileq = jobname(1:ljob)//'.pmx'
- inquire(file=infileq,EXIST=fexist)
- if (.not.fexist) then
- inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist)
- if (.not.fexist) then
- print*,'Cannot find file '//infileq
- call stop1()
- else
- infileq = jobname(1:ljob)//'.PMX'
- end if
- end if
-c
-c Open a log file
-c
- open(15,file=jobname(1:ljob)//'.pml')
- call printl('This is PMX, Version '//version//', '//date)
- ljob4 = ljob
- call printl('Opening '//infileq)
- open(18,file=infileq)
-c
-c Copy input file into common buffer
-c
- ipbuf = 0
- linewcom(1) = 1
- do 8 ilbuf = 1 , maxblks
- ncomments = 0
-14 read(18,'(a)',end=9)lnholdq
- lbuf(ilbuf) = lenstr(lnholdq,128)
- if (lbuf(ilbuf) .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lbuf(ilbuf) = 1
- lnholdq = ' '
- end if
-c
-c Now line has at least one non blank character. Check for comment
-c As of Version 260, do not copy comments into bufq
-c But need to count %'s for error messaging
-c if (lnholdq(1:1).eq.'%') go to 14
- if (lnholdq(1:1).eq.'%') then
- ncomments = ncomments+1
- go to 14
- end if
-c
-c When here, have counted all preceding comments and have a real line
-c
- if (ilbuf .gt. 1) then
- linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments
- else
- linewcom(1) = 1+ncomments
- end if
- if (ipbuf+lbuf(ilbuf).gt.65536) then
- print*,'Too many characters in file, stopping'
- call stop1()
- end if
- bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq
- ipbuf = ipbuf+lbuf(ilbuf)
-8 continue
- call printl('Too many lines in input file')
- call stop1()
-9 continue
-c
-c Insert dummy line to handle input files w/o CR-LF at end.
-c
- nlbuf = ilbuf-1
-c nlbuf = ilbuf
-c bufq(ipbuf+1:ipbuf+3) = ' / '
-c lbuf(nlbuf) = 3
- close(18)
- do 6 numit = 1 , maxit
- if (optimize) call printl('Starting an iteration')
-c
-c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0.
-c Otherwise, nbars0 is the input
-c When islast=.false., pmxb only returns poe's, otherwise does whole job
-c
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize)
- if (.not.optimize) then
- if (ismidi) then
-c
-c Set up channel numbers for midi.
-c
- numchan = 0
- do 11 iv = nv , 1 , -1
- if (twoline(iv)) then
- midchan(iv,2) = numchan
- numchan = numchan+1
- end if
- midchan(iv,1) = numchan
- numchan = numchan+1
-11 continue
-c
-c numchan will now be the number of channels, but max channel # is numchan-1
-c
-c Set up velocities, balances, and midi-transpositions
-c
- do 13 iv = nv , 1 , -1
- if (twoline(iv)) then
- midvelc(midchan(iv,2)) = midivel(iv)
- midbc(midchan(iv,2)) = midibal(iv)
- midtc(midchan(iv,2)) = miditran(iv)
- end if
- midvelc(midchan(iv,1)) = midivel(iv)
- midbc(midchan(iv,1)) = midibal(iv)
- midtc(midchan(iv,1)) = miditran(iv)
-13 continue
- end if
-c
-c TEMPORARY!!!
-c
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- do 10000 ilb = 1 , nlbuf
-c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb),
-c * bufq(ip1:ip1+lbuf(ilb)-1),
-c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)),
-c * k=min(3,lbuf(ilb)),1,-1)
- ip1 = ip1+lbuf(ilb)
-10000 continue
- iplast = ip1-1
-c
-c Check to see if (1) last line is "<blank><blank>/" 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 "<blank><blank>/"'
- write(15,*)'Removing last line of "<blank><blank>/"'
- nlbuf = nlbuf-1
- end if
- end if
-c
- call pmxb(.true.,poe0,ncalls,optimize)
- if (ismidi) then
-c
-c Write midi file
-c
- open(51,file=jobname(1:ljob)//'.mid')
- if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm')
- call printl(' ')
- call printl('Writing '//jobname(1:ljob)//'.mid')
- call writemidi(jobname,ljob)
- end if
- close(15)
- stop
- end if
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- call pmxb(.false.,poe0,ncalls,optimize)
- call poestats(nsyst,poe0,poebar0,devnorm0)
-c
-c Save initial deviation and line breaks for later comparison
-c
- if (numit .eq. 1) then
- devpmx = devnorm0
- do 20 isys = 1 , nsyst
- nbari(isys) = nbars0(isys)
-20 continue
- end if
- call sortpoe(nsyst,poe0,ipoe)
- do 1 iupord = nsyst , 1 , -1
- isysu = ipoe(iupord)
- print*,'isysu=',isysu
- write(15,*)'isysu=',isysu
-c
-c Skip if system isysu has poe0 < avg or isysd has poe0 > avg
-c
- if (poe0(isysu).lt.poebar0) go to 1
- do 5 idnord = 1 , nsyst
- isysd = ipoe(idnord)
- if (isysu.eq.isysd .or. nbars0(isysd).eq.1
- * .or. poe0(isysd).gt.poebar0) go to 5
- do 2 isyst = 1 , nsyst
- nbars(isyst) = nbars0(isyst)
- if (isyst .eq. isysu) then
- nbars(isyst) = nbars(isyst)+1
- else if (isyst .eq. isysd) then
- nbars(isyst) = nbars(isyst)-1
- end if
-2 continue
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize)
- call pmxb(.false.,poe,ncalls,optimize)
- call poestats(nsyst,poe,poebar,devnorm)
- if (devnorm .lt. devnorm0) then
- devnorm0 = devnorm
- poebar0 = poebar
- do 4 isys = 1 , nsyst
- nbars0(isys) = nbars(isys)
- poe0(isys) = poe(isys)
-4 continue
- print*,'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(15,*)'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call sortpoe(nsyst,poe0,ipoe)
- go to 6
- end if
-5 continue
-1 continue
-c
-c If we get here, must have gone thru all switches and found nothing better,
-c so done!
-c
- go to 7
-6 continue
-7 continue
- print*,'Optimum located, numit:',numit,', ncalls:',ncalls
- write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls
- print*,'Final error:',devnorm0,', initial error:',devpmx
- write(15,*)'Final error:',devnorm0,', initial error:',devpmx
- print*,'Percentage improvement:',100.*(1-devnorm0/devpmx)
- write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx)
- call printl('Initial bars/system:')
- write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- call printl('Final bars/system:')
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize)
- call pmxb(.true.,poe0,ncalls,optimize)
-c itend = mytime()
-c print*,'Elapsed time in ms:',itend-itstart
-c write(15,*)'Elapsed time in ms:',itend-itstart
- close(15)
- end
- subroutine accsym(nacc,acsymq,lacc)
- character*3 acsymq
- iacc = iand(nacc,7)
- if (iacc .eq. 1) then
- acsymq = 'fl'
- lacc = 2
- else if (iacc .eq. 2) then
- acsymq = 'sh'
- lacc = 2
- else if (iacc .eq. 3) then
- acsymq = 'na'
- lacc = 2
- else if (iacc .eq. 5) then
- acsymq = 'dfl'
- lacc = 3
- else if (iacc .eq. 6) then
- acsymq = 'dsh'
- lacc = 3
- else
- print*,'bad accidental: ',iacc
- end if
- return
- end
- subroutine addask(taskn,waskn,elaskn,
- * fixednew,scaldold,tglp1,isudsp)
- parameter (nm=24)
- logical isudsp
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comtol/ tol
- if (isudsp) then
-c
-c Find which udsp we're dealing with
-c
- do 1 iudsp = 1 , nudsp
- if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2
-1 continue
- print*,'You should note BEEE here in addask!'
- call stop1()
-2 continue
-c
-c Fixednew and scaldold must not be changed, since udsp's are already included
-c in fsyst from pmxa, and udsp don't involve scaled space..
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c Must add user-defined space to what's there already.
-c
- wask(naskb) = wask(naskb)+udsp(iudsp)
- else
-c
-c This place has no other space.
-c
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = udsp(iudsp)
- elask(naskb) = 0.
- end if
- else
-c
-c This is a normal space, no effect if smaller than existing space
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c We already put in some space at this time
-c Check if new one needs more space than old one at same time
-c
- if (waskn .gt. wask(naskb)) then
- naskb = naskb-1
- else
- return
- end if
- end if
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = waskn
- elask(naskb) = elaskn
- fixednew = fixednew+waskn
- scaldold = scaldold+elaskn
- end if
- return
- end
- subroutine addblank(noteq,lnoten)
- character*8 noteq
- character*1 tchar
- tchar = noteq
- noteq = ' '//tchar
- lnoten = 2
- return
- end
- subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd)
- parameter (nm=24)
- integer nfb(nm)
- common /comtol/ tol
- real*4 t1fb(nm,20),t2fb(nm,20)
- character*1 ulfbq(nm,20)
- ifbadd = 1
- nfb(iv) = nfb(iv)+1
- do 1 ifb = nfb(iv)-1 , 1 , -1
- if (tnew .lt. t1fb(iv,ifb)-tol) then
- t1fb(iv,ifb+1) = t1fb(iv,ifb)
- t2fb(iv,ifb+1) = t2fb(iv,ifb)
- ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
- else
- ifbadd = ifb+1
- go to 2
- end if
-1 continue
-2 continue
- t1fb(iv,ifbadd) = tnew
- ulfbq(iv,ifbadd) = 'x'
- return
- end
-c
-c
- subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest)
- parameter(nm=24,mv=24576)
- integer*2 mmidi,itk(25)
- integer*4 itiesav(5,100)
- character*1 notenumq
- logical endrest,eximacc,it1found
- logical rest
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- common /comdiag/ n69(0:nm),n34(0:nm)
-c
-c Following variables are local but must be saved. I hope they are.
-c (3/18/00) With g77 they are not, so add a common block here.
-c
-c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12)
- integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15)
- common /comips/ ipslon,lusebl,jusebl
-c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c
-c Cancel out barline accidentals if there's a rest.
-c
- if (rest) naccbl(icm) = 0
-c
-c Special path to insert dummy rest at end of a section
-c
- if (endrest) go to 20
-c
- do 7 ion = 0 , nmidcrd
-c
-c check if this is only to get pitch of a chord note
-c
- if (notmain) go to 6
-c
-c check for rest
-c
- if (rest) then
-c
-c Will not put in a note, but must update timing
-c
- if (.not.restpend(icm)) then
-c
-c First rest in sequence, save the time
-c
- restpend(icm) = .true.
- trest(icm) = time
- else
- trest(icm) = trest(icm)+time
- end if
-c
-c Note: code checkers don't like the above due to calling addmidi(trest(icm))
-c but this only happens if rest at end of section (endrest=.true.) (called
-c from getmidi(), in which case these above lines are bypassed.
-c
- call chkimidi(icm)
- return
- end if
-c
-c time tics
-c
- if (imidi(icm).gt.0 .and. ion.eq.0) then
- idur = mgap
- else
- idur = 0
- end if
- if (restpend(icm)) then
- restpend(icm) = .false.
- idur = idur+nint(15*trest(icm))
- end if
-c
-c time to start of note
-c
- idurvar = isetvarlen(idur,nby2on)
- if (nby2on .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- do 2 i = 1 , nby2on
-c
-c imidi points to cell before highest (leftmost) byte. Start with lowest byte
-c at far right, fill in backwards
-c
- mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256)
- if (nby2on .gt. 1) idurvar = idurvar/256
-2 continue
- imidi(icm) = imidi(icm)+nby2on-1
-c
-c Note-on signal
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 9*16+icm
- mmidi(icm,imidi(icm)) = 9*16+icmm(icm)
-c
-c Entry point for chord note pitch determination
-c
-6 continue
-c
-c Get midi pitch. On chord iteration, only do this first time (main note),
-c since pitch was already computed for nonmain chord notes.
-c
- if (ion .eq. 0) then
- ipsav = nolev*12./7+11
- ipsav0 = ipsav
- if (isig .ne. 0) then
-c
-c Adjust for signature
-c
- notenumq = char(48+mod(nolev,7))
- if (isig.ge.index('4152630',notenumq)) then
- ipsav = ipsav+1
- else if (-isig.ge.index('0362514',notenumq)) then
- ipsav = ipsav-1
- end if
- end if
-c
-c Deal with accidentals.
-c
-c iacc 0 1 2 3 4 5 6 7
-c effect X fl sh na X dfl dsh X
-c iashft X -1 1 0 X -2 2 X
-c
- jacc = 0
- eximacc = .false.
- if (iacc .gt. 0) then
-c
-c Adjust key-sig-adjusted pitch for explicit accidental (and exit)
-c
- jacc = iashft(iacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
-c
-c (Above) Shift applies to diatonic pitch but will be added to adjusted one
-c
- else if (naccim(icm) .gt. 0) then
-c
-c Possible implicit accidental from earlier in the bar
-c Check for prior accid in this bar at this note level
-c
- do 3 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- jacc = jaccim(icm,kacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 4
- end if
-3 continue
-4 continue
- end if
-c
-c Must split off the following if block from those above because chord
-c notes can cause naccim>0, forcing us to miss other chord note's
-c accross-bar-line accidental
-c
- if (naccbl(icm).gt.0 .and. .not.eximacc) then
-c
-c Possible carryover accid from prior bar (or prior same-pitch note).
-c
- do 21 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev) then
- jacc = jaccbl(icm,kacc)
-c
-c Since we are *using* the bar-line accid, must flag it to be saved for next.
-c
- nusebl = nusebl+1
- jusebl(nusebl) = jacc
- lusebl(nusebl) = nolev
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 22
- end if
-21 continue
-22 continue
- end if
- ipsav = ipsav+jacc
-c
-c Midi transpositions
-c
- ipsav = ipsav+midtc(icm)
- end if
- if (notmain) then
- mcpitch(nmidcrd) = ipsav
-c
-c Save pitch for tie checks
-c
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- imidi(icm) = imidi(icm)+1
- if (ion.eq.0) then
- mmidi(icm,imidi(icm)) = ipsav
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ion)
- end if
- end if
- if (ion .eq. 0) then
-c
-c Only record accids for non-chords, main chord note during chord iteration
-c and chordnotes on first call but not during iteration
-c
- if (iacc.gt.0) then
-c
-c Set marker for accidental for possible continuations later this bar
-c but first check and clear earlier ones on same note.
-c
- do 23 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- do 24 macc = kacc , naccim(icm)-1
- laccim(icm,macc) = laccim(icm,macc+1)
- jaccim(icm,macc) = jaccim(icm,macc+1)
-24 continue
- go to 25
- end if
-23 continue
- go to 26
-25 continue
- naccim(icm) = naccim(icm)-1
-26 continue
-c
-c Flag new accidental
-c
- naccim(icm) = naccim(icm)+1
- laccim(icm,naccim(icm)) = nolev
- jaccim(icm,naccim(icm)) = iashft(iacc)
- end if
-c
-c Bail if this is a chord note on the first call (from docrd)
-c
- if (notmain) then
- call chkimidi(icm)
- return
- end if
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 127
- mmidi(icm,imidi(icm)) = midvelc(icm)
- call chkimidi(icm)
-7 continue
-c
-c For tie checks
-c
- if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm)
-c
-c Entry point for special rests at section ends (endrest=T)
-c
-20 continue
-c
-c Now insert all the ends
-c
- do 8 ioff = 0 , nmidcrd
- if (ioff .eq. 0) then
-c
-c time to end
-c
- idur1 = nint(15*time)
- if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then
- idur = idur1-mgap
- else
- idur = idur1
- end if
-c
-c Deal with roundoff problems with 7-tuplets on half or quarters
-c
- if (idur1 .eq. 69) then
- n69(icm) = n69(icm)+1
-c if (mod(n69(icm)+6,7) .gt. 3) idur = 58
- if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1
- else if (idur1 .eq. 34) then
- n34(icm) = n34(icm)+1
- if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1
- end if
- idurvar = isetvarlen(idur,nby2off)
- if (nby2off .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- call chkimidi(icm)
- do 1 i = 1 , nby2off
- mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256)
- if (nby2off .gt. 1) idurvar = idurvar/256
-1 continue
- imidi(icm) = imidi(icm)+nby2off-1
- else
-c
-c Inserting end of chord note, delta time is 0
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- end if
-c
-c Note off
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 8*16+icm
- mmidi(icm,imidi(icm)) = 8*16+icmm(icm)
-c
-c Pitch
-c
- imidi(icm) = imidi(icm)+1
- if (ioff .eq. 0) then
- mmidi(icm,imidi(icm)) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ioff)
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- call chkimidi(icm)
- if (endrest) then
- return
- end if
-c
-c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time
-c
-8 continue
- naccbl(icm) = nusebl
- if (nusebl .gt. 0) then
-c
-c Fix tables of "bar-line" accids that are saved due to consecutive notes.
-c
- do 30 kacc = 1 , nusebl
- laccbl(icm,kacc) = lusebl(kacc)
- jaccbl(icm,kacc) = jusebl(kacc)
-30 continue
- nusebl = 0
- end if
-c
-c Begin tie checks
-c
- if (slmon(icm)) then
-c
-c Prior note had a slur start
-c
- if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then
-c
-c We have a tie! (Assumed there would be no accidental on tie-ending note)
-c Make a list of times of all events back to the one starting at imidso+1,
-c which is at or before where the tie started. Ident tie start and stop by
-c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie)
-c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial
-c time.
- nsav4tie = 0
- imidt = imidso(icm)
-10 nsav4tie = nsav4tie+1
- itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes)
- imidt = imidt+nbytes
- do 11 j = 1 , 3
- itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j)
-11 continue
- imidt = imidt+3
- if (nsav4tie .eq. 1) then
- itiesav(5,1) = itiesav(1,1)
- else
- itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+
- * itiesav(5,nsav4tie-1)
- end if
- if (imidt .ne. imidi(icm)) go to 10
-c
-c Find which two pitches agree with saved slur pitch.
-c
- it1found = .false.
- do 12 it2 = 1 , nsav4tie
- if (itiesav(3,it2) .eq. ipslon(icm)) then
- if (it1found) go to 13
- it1 = it2
- it1found = .true.
- end if
-12 continue
- call printl(
- * 'Program error, tied notes, send source to Dr. Don')
- it1 = nsav4tie+1
- it2 = nsav4tie+1
-13 continue
-c
-c List the positions we want to keep
-c
- jsav = 0
- do 14 isav = 1 , nsav4tie
- if (isav.eq.it1 .or. isav.eq.it2) go to 14
- jsav = jsav+1
- itk(jsav) = isav
-14 continue
- nsav4tie = nsav4tie-2
-c
-c Now dump events it1 & it2, recompute times, restack mmidi.
-c
- imidi(icm) = imidso(icm)
- do 15 isav = 1 ,nsav4tie
- if (isav .eq. 1) then
- idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes)
- else
- idurvar = isetvarlen(itiesav(5,itk(isav))-
- * itiesav(5,itk(isav-1)),nbytes)
- end if
- imidi(icm) = imidi(icm)+1
- do 16 i = 1 , nbytes
- mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256)
- if (nbytes .gt. 1) idurvar = idurvar/256
-16 continue
- imidi(icm) = imidi(icm)+nbytes-1
- do 17 i = 2 , 4
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = itiesav(i,itk(isav))
-17 continue
-15 continue
- end if
- slmon(icm) = .false.
- levsoff(icm) = 0
- if (.not.dbltie) levson(icm) = 0
- end if
- if (levson(icm).gt.0) slmon(icm) = .true.
- if (nmidcrd .gt. 0) nmidcrd = 0
- call chkimidi(icm)
- return
- end
- subroutine addstr(notexq,lnote,soutq,lsout)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- character*(*) notexq
- character*80 soutq
- if (lsout+lnote .gt. 72) then
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- end if
- if (lsout .gt. 0) then
- soutq = soutq(1:lsout)//notexq(1:lnote)
- else
- soutq = notexq(1:lnote)
- end if
- lsout = lsout+lnote
- return
- end
- subroutine adjusteskz(ib,squez,istart,istop,poenom)
-c
-c For block ib, this adds accidental spaces to eskz, for use in getting
-c length of xtup bracket and slopes of brackets and beams.
-c
- parameter (nm=24)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- real*4 squez(80)
- integer*4 istart(80),istop(80)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comeskz2/ eskz2(nm,200)
- common /comtol/ tol
- common /comntot/ ntot
- inmin = istart(ib)+1
- do 10 iaskb = 1 , naskb
- if (task(iaskb) .lt. to(istart(ib))-tol) go to 10
- eskadd = wask(iaskb)/poenom-elask(iaskb)
- do 11 in = inmin , ntot
- if (to(in) .gt. task(iaskb)-tol) then
- eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd
- if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1
- else
- inmin = inmin+1
- end if
-11 continue
-10 continue
- return
- end
- subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- logical figbass,ispoi,topmods,istype0,done,isbbm
- common /comhsp/ hpttot(176)
- common /compoi/ ispoi
- common /combbm/ isbbm
- common /comas3/ ask(2500),iask,topmods
- character*40 pathnameq
- character*44 basenameq
- character*1 sq,chax
- character*129 outq
- sq = chax(92)
- open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex')
-c
-c Transfer first 5 lines of main internal TeX file
-c
- do 11 il = 1 , 5
- call moveln(11,12,done)
-11 continue
- if (istype0) then
-c
-c Transfer literal TeX stuff from special scratch file
-c
- rewind(17)
-10 call moveln(17,12,done)
- if (.not.done) go to 10
- close(17)
- end if
-c
-c Transfer next 2 lines from main scratch file
-c
- do 3 il = 1 , 2
- call moveln(11,12,done)
-3 continue
- if (ispoi) write(12,'(a)')sq//'input musixpoi'
- if (isbbm) write(12,'(a)')sq//'input musixbbm'
- if (figbass) then
-c
-c Transfer .fig data from scratch (unit 14) into external .tex (unit 12)
-c
-4 call moveln(14,12,done)
- if (.not.done) go to 4
- close(14)
- end if
- iask = 0
- ihs = 0
-1 read(11,'(a129)',end=999)outq
-c
-c Hardspaces.
-c
- if (outq(1:5) .eq. sq//'xard') then
- ihs = ihs+1
- outq(2:2) = 'h'
- write(outq(12:15),'(f4.1)')hpttot(ihs)
- lenout = 19
- go to 9
- end if
-c
-c This part hard-wires ask's into new .tex file as ast's
-c
-2 indxask = index(outq,sq//'ask')
- if (indxask .ne. 0) then
- iask = iask+1
- call putast(ask(iask),indxask,outq)
- go to 2
- end if
- lenout = llen(outq,129)
-9 continue
- write(12,'(a)')outq(1:lenout)
-c
-c If this is the line with "readmod", check for topmods.
-c
- if (topmods .and. outq(2:8).eq.'readmod') then
- topmods = .false.
- rewind(16)
- do 7 il = 1 , 1000
- read(16,'(a129)',end=8)outq
- lenout = llen(outq,129)
-c
-c We inserted the '%' in subroutine littex, to guarantee including blank.
-c
- write(12,'(a)')outq(1:lenout)
-7 continue
-8 continue
- close(16)
- end if
- go to 1
-999 close(11)
- close(12)
- return
- end
- subroutine backfill(iunit,oldq,lenold,newq,lennew)
-c
-c In iunit, looks backward for oldq, overwrites newq
-c Safest if both are same length!
-c
- character*128 lineq(200),nowq
- character*(*) oldq,newq
- linesback = 0
-1 continue
- backspace(iunit)
- read(iunit,'(a)')nowq
- ndx = index(nowq,oldq(1:lenold))
-c
-c Save the line just read
-c
- linesback = linesback+1
- lineq(linesback) = nowq
- if (ndx .eq. 0) then
- backspace(iunit)
- go to 1
- end if
-c
-c If here, it's replacement time.
-c
- lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew)
- * //nowq(ndx+lenold:128)
- backspace(iunit)
- do 2 line = linesback , 1 , -1
- write(iunit,'(a128)')lineq(line)
-2 continue
- return
- end
- subroutine beamend(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comoct/ noctup
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- character*4 tempq
- character*8 noteq
- character*79 notexq
- ip = ipo(jn)
- multip = iand(mult(ivx,ip),15)-8
- if (ixrest(ivx) .eq. 4) then
-c
-c This is the LAST note in the xtup (i.e., all rests before). Make single.
-c
- nodur(ivx,ip) = 2**(4-multip)
- call notex(notexq,lnote)
- ixrest(ivx) = 0
- return
- end if
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip-1),27))
- * nodur(ivx,ip)=nodur(ivx,ip)/2
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = lnoten+3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note is not regular-dotted
-c
-
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnote+1
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnote+2
- else if (multip .eq. -2) then
- notexq = sq//'wh'//noteq
- else if (multip .eq. -3) then
- notexq = sq//'breve'//noteq
- lnote = lnote+3
- else
- print*
- print*,'(Error in beamend, send source to Dr. Don)'
- call stop1()
- end if
- else
-c
-c Prior note is regular-dotted so this one is halved
-c
- if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- end if
- end if
- end if
- return
- end if
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- lnote = 0
-c
-c New way, with flipend, which was computed in beamstrt.
-c
- if (flipend(ivx) .and. btest(ipl(ivx,ip),30))
- * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then
-c
-c This is not a one-noter from beam-jump. Check if multiplicity has increased
-c
- if (btest(irest(ivx,ip-1),0)) then
-c
-c Prior note is a rest, check one before that
-c
- mp = iand(mult(ivx,ip-2),15)-8
- else
- mp = iand(mult(ivx,ip-1),15)-8
- end if
- if (multip .gt. mp) then
-c
-c Assume 1-3, 2-3, or 1-2
-c
- do 2 imp = multip , mp+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
-2 continue
- else if (btest(nacc(ivx,ip-1),27)) then
-c
-c 2nd member of dotted xtup
-c
- call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
- end if
-c
-c Beam termination and direction analysis
-c
- if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then
-c
-c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number
-c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the
-c voice of the 2nd part of jumped beam. (May need special treatment for
-c multi-segment jump-beams
-c
- isbjmp = .true.
- ivbj1 = ivx
- ivbj2 = 0
- end if
- if (.not.btest(irest(ivx,ip),23)) then
-c
-c This is either a normal beamend or end of a sequence of jump-beam segments,
-c so some sort of termination is required
-c
- ulqq = ulq(ivx,ibmcnt(ivx))
- if (.not.isbjmp .or. ivx.ne.ivbj2) then
-c
-c Normal termination
-c
- call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote)
- else
-c
-c Terminate a sequence of jump-beam segments.
-c
- ulqq = chax(225-ichar(ulqq))
- call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote)
- end if
- end if
-c
-c And now the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (.not.btest(iornq(ivx,ip),13)) then
- notexq = notexq(1:lnote)//'p'
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
-c
-c 5/25/08 Allow >12
-c 5/9/10 Up to 24; replace 24 with 0
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
-c call istring(mod(ivx,12),tempq,len)
- call istring(mod(ivx,24),tempq,len)
- else
-c call istring(mod(ivbj1,12),tempq,len)
- call istring(mod(ivbj1,24),tempq,len)
- end if
- if (isbjmp .and. ivx.eq.ivbj2
- * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false.
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamid(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm
- character*79 notexq
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- character*8 noteq
- character*4 tempq
- lnote = 0
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- multip = iand(mult(ivx,ip),15)-8
-c if (btest(islur(ivx,ip-1),3)) multip = multip+1
-c
-c (Above test OK since must have ip>1). Double dotted note preceding
-c
-c Move the following, because can't ask for note until after checking for
-c embedded xtup with number, due to ordering/octave feature.
-c
-c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
- end if
- if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true.
- if (vxtup(ivx)) then
-c
-c In an xtup
-c
- if (btest(irest(ivx,ip),0)) then
-c
-c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK
-c
- nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8))
- call notex(notexq,lnote)
-c
-c Re-zero so next note does not get confused
-c
- nodur(ivx,ip) = 0
- return
- end if
-c if (multip.le.0) then
-c if (multip.le.0 .or.
-c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip),19) .or.
- * btest(nacc(ivx,ip),27)) then
- nodur(ivx,ip)=3*nodur(ivx,ip)/2
- else if (btest(nacc(ivx,ip-1),27)) then
- nodur(ivx,ip)=nodur(ivx,ip)/2
- end if
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
-c
-c Use ulq for stem direction
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note is not regular-dotted
-c
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- end if
- if (btest(nacc(ivx,ip),27)) then
-c
-c This note is regular dotted non-beamed xtup
-c
- notexq = notexq(1:3)//'p'
- lnote = 4
- end if
- else
-c
-c Prior note is regular-dotted so this one is halved
-c
- if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- end if
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- else if (nodur(ivx,ip).eq.0) then
-c
-c In the beamed xtup but not the last note
-c
- if (nodur(ivx,ip-1).gt.0) then
-c
-c Embedded Xtup, mult>0, starts here. Put in number if needed
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- iud = 1
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1
-c
-c Get ip#, notelevel of middle note (or gap) in xtup
-c
- ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ip),14)) then
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Place number if needed
-c
- if (.not.btest(islur(ivx,ip),31)) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
- call putxtn(mprint,iflop,multip,iud,wheadpt,poenom,
- * nolev1(ivx),islope(ivx),slfac,
- * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
- * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.)
- end if
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- else
-c
-c Intermediate note of xtup
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else
-c
-c Last note of xtup (but not last note of beam!)
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else if (btest(irest(ivx,ip),0)) then
- call notex(notexq,lnote)
- return
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
-c
-c Check if multiplicity changes in a way requiring action
-c
- ipleft = ip-1
- if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
- if (.not.btest(islur(ivx,ipleft),20)) then
- multl = iand(15,mult(ivx,ipleft))-8
- else
- multl = 1
- end if
- mub = multip - multl
- ipright = ip+1
- if (btest(irest(ivx,ipright),0)) ipright = ipright+1
- if (.not.btest(islur(ivx,ip),20)) then
- multr = iand(15,mult(ivx,ipright))-8
- else
- multr = 1
- end if
- mua = multr-multip
- if (mub.gt.0 .or. mua .lt. 0) then
-c
-c Multiplicity has increased from left or will decrease to right. Need action.
-c
- if (isbjmp .and. ivx.eq.ivbj2) then
- ivb = ivbj1
- ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- else
- ivb = ivx
- ulqq = ulq(ivx,ibmcnt(ivx))
- end if
- if (mua .ge. 0) then
- call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote)
- else if (multl .ge. multr) then
- do 1 im = multip , 1+multr, -1
- call ntrbbb(im,'t',ulqq,ivb,notexq,lnote)
-1 continue
- else
- do 2 im = 1+multr, multip
- call ntrbbb(im,'r',ulqq,ivb,notexq,lnote)
-2 continue
- call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote)
- end if
- else if (ip .gt. 1) then
-c
-c Check for 2nd member of dotted xtup
-c
- if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
-c
-c Now put in the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- isdotm = .false.
- if (isdotted(nodur,ivx,ip)) then
-c
-c rule out ')'
-c
- if (.not.btest(iornq(ivx,ip),13)) then
- if (.not.btest(islur(ivx,ip),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- else if (btest(nacc(ivx,ip),19)
- * .or. btest(nacc(ivx,ip),27)) then
-c
-c Special dotted notation for 2:1 xtup, or normal dot in xtup
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c 5/25/08 Allow >12
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
-c call istring(mod(ivx,12),tempq,len)
- call istring(mod(ivx,24),tempq,len)
- else
-c call istring(mod(ivbj1,12),tempq,len)
- call istring(mod(ivbj1,24),tempq,len)
- end if
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamn1(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- common /comoct/ noctup
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*8 noteq
- character*79 notexq
- ip1 = ipo(jn)
- multip = iand(15,mult(ivx,ip1))-8
-c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then
- if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then
- lnote = 0
-c
-c The rest was already written in beamstrt, so just get out of here
-c
- return
- end if
- nole = nolev(ivx,ipo(jn))
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ipo(jn)),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ipo(jn)),31)) then
- nole = nole + 1
- end if
- if (vxtup(ivx) .and. .not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip1),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip1)
- nodur(ivx,ip1) = 2**(4-multip)
- if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2
- call notex(notexq,lnote)
- nodur(ivx,ip1) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- else if (multip .eq. -3) then
- notexq = sq//'breve'
- lnote = 6
- else
- print*
- print*,'(Error in beamn1, send source to Dr. Don)'
- call stop1()
- end if
- if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then
- notexq = notexq(1:3)//'p'
- lnote = 4
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- end if
-c
-c Check if mult. decreases from 1st note to 2nd
-c
- if (ibm2(ivx,ibmcnt(ivx)).gt.ip1
- * .or. btest(islur(ivx,ip1),20)) then
-c
-c More than one note or single-note before a multiplicity-down-up "]["
-c
- if (btest(islur(ivx,ip1),20)) then
- multr = 1
- else if (.not.btest(irest(ivx,ip1+1),0)) then
- multr = iand(15,mult(ivx,ip1+1))-8
- else
- multr = iand(15,mult(ivx,ip1+2))-8
- end if
- lnote = 0
- if (multr .lt. multip) then
- do 1 im = multip , multr+1 , -1
- call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
-1 continue
- end if
- end if
-c
-c Put in the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
-c
-c Check for dot
-c
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- nd = nodur(ivx,ipo(jn))
- if (nd.ne.0) then
- if (2**log2(nd).ne.nd) then
- if (.not.btest(iornq(ivx,ip1),13)) then
- if (.not.btest(islur(ivx,ip1),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
- else if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) then
-c
-c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c Do the number; 0 if 12
-c
-c 5/25/08 allow >12
-c
- if (.not.btest(irest(ivx,ip1),24)) then
-c call istring(mod(ivx,12),noteq,len)
- call istring(mod(ivx,24),noteq,len)
- else
-c call istring(mod(ivbj1,12),noteq,len)
- call istring(mod(ivbj1,24),noteq,len)
- end if
- notexq = notexq(1:lnote)//noteq(1:len)
- lnote = lnote+len
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- character*79 inameq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm
- common /comeskz2/ eskz2(nm,200)
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c The following is just to save the outputs from SetupB for the case of
-c xtups starting with a rest, where beamstrt is called twice.
-c
- common /comipb/ nnb,sumx,sumy,ipb(24),smed
- character*8 noteq
- character*79 notexq,tempq
- integer nornb(nm),ihornb(nm,24)
- real*4 space(80),squez(80)
- logical novshrinktop,cstuplet,usexnumt
- common /comnvst/ novshrinktop,cstuplet
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figq
- ibc = ibmcnt(ivx)
- ipb1 = ibm1(ivx,ibc)
- multb = iand(15,mult(ivx,ipb1))-8
- ip = ipo(jn)
-c
-c Compute slopes and note offsets from start of beam. Inside SetupB, for each
-c xtup in the beam, set eloff,mtupv (in comxtup) for printed number.
-c
- if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21))
- * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx))
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is start of later segment of single-slope beam group so use slope and
-c height from prior beam. Slope is already OK.
-c
- issb(ivx) = issb(ivx)+1
- nolev1(ivx) = lev1ssb(ivx,issb(ivx))
- end if
- lnote = 0
- drawbm(ivx) = .true.
- if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then
- vxtup(ivx) = .true.
- nxtinbm(ivx) = nxtinbm(ivx)+1
-c
-c irest(28)=>Xtup starts on this note. Set up for xtuplet.
-c Number goes on notehead side at middle note (or gap) of xtup, unless that
-c puts it in staff, then it flops to stem (or beam) side.
-c __ __
-c | | | O | |
-c O | | O
-c |___| O |__| |
-c
-c iud -1 -1 1 1 ...stem direction
-c iflop 0 1 -1 0 ...direction of flop
-c iup -1 1 -1 1 ...direction of number and bracket
-c
- iud = 1
- if (ulq(ivx,ibc) .eq. 'u') iud = -1
-c
-c Get ip#, note level of middle note (or gap) in xtup
-c
- ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ipb1),14)) then
-c
-c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic)
-c
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Determine if a beam is to be drawn
-c
- do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc)
- if (iand(15,mult(ivx,ipp))-8 .le. 0) then
- drawbm(ivx) = .false.
- go to 6
- end if
-5 continue
- drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18)
-6 continue
-c
-c Are we using tuplet.tex?
-c
- usexnumt = cstuplet .and. .not.drawbm(ivx)
-c
-c Place xtup number if needed
-c
- if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
- call putxtn(mprint,iflop,multb,iud,wheadpt,
- * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1),
- * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)),
- * iup,irest(ivx,ipb1),usexnumt)
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam
-c
- if (.not.btest(islur(ivx,ipb1),31)) then
-c
-c Number printing has not been suppressed, so put in the bracket.
-c scale = stretch factor for bracket if there are asx's
-c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon)
-c
- xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1)
- * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib))
- if (iup .eq. 1) then
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'ovbkt'
- else
- notexq = sq//'ovbkt'
- end if
- else
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'unbkt'
- else
-c
-c Introduced 12/5/98, req'd due to possible presence of in-line TeX
-c
- notexq = sq//'unbkt'
- end if
- end if
- lnote = lnote+6
- if (iline.eq.1) then
- smed = smed/(1.-fracindent)
- end if
- xslope = 1.8*smed*slfac
- islope(ivx) = nint(xslope)
- nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1))
- if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1
- if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4
- levbracket = nolev1(ivx)
- if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1
- call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
- if (xnsk .lt. 0.995) then
- write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk
- lnote = lnote+4
- else if (xnsk .lt. 9.995) then
- write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk
- lnote = lnote+5
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- if (btest(mult(ivx,ipb1),4)) then
-c
-c Tweak slope of bracket
-c
- islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16
- end if
- if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (islope(ivx) .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx)
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx)
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx)
- lnote = lnote+1
- end if
-c
-c Done with bracket
-c
- end if
- if (ixrest(ivx) .eq. 1) then
-c
-c Put in the rest. Possible problem: Rest is a spacing char, but between
-c beamstrt and beamn1 some non-spacing chars. are inserted.
-c
- if (multb .eq. 0) then
- notexq = notexq(1:lnote)//sq//'qp'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.1) then
- notexq = notexq(1:lnote)//sq//'ds'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.2) then
- notexq = notexq(1:lnote)//sq//'qs'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.3) then
- notexq = notexq(1:lnote)//sq//'hs'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//sq//'hpause'
- lnote = lnote+7
- end if
-c
-c No need to come back through this subroutine (as would if rest starts bar
-c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing.
-c
- ixrest(ivx) = 0
- end if
- return
- end if
-c
-c End if block for non-beamed xtup start...note we returned
-c
- if (ixrest(ivx) .eq. 1) then
-c
-c Insert rest at start of beamed xtup. See above note for possible problem.
-c
- nodur(ivx,ipb1) = 2**(4-multb)
- call notex(tempq,ltemp)
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//tempq(1:ltemp)
- else
- notexq = tempq(1:ltemp)
- end if
- lnote = lnote+ltemp
-c
-c Re-zero just in case!
-c
- nodur(ivx,ipb1) = 0
- ibm1(ivx,ibc) = ibm1(ivx,ibc)+1
-c
-c See if next note is a non-rest
-c
- if (.not.btest(irest(ivx,ipb1+1),0)) then
- ixrest(ivx) = 2
- else
-c
-c Suppress reprinting xtup number next time through beamstrt
-c
- islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31)
-c
-c Set new xtup start flag
-c
- irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28)
- end if
- return
- end if
- end if
-c
-c Just ended if block for xtups
-c
- if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then
-c
-c Move actual note writing to beamend
-c
- ixrest(ivx) = 4
- return
- end if
- if (issb(ivx) .eq. 0) then
-c
-c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed
-c
- iadj = igetbits(ipl(ivx,ipb1),6,11)-30
- if (iadj .ne. -30) then
- nolev1(ivx) = nolev1(ivx)+iadj
- do 2 isssb = 1 , nssb(ivx)
- lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj
-2 continue
- end if
- iadj = igetbits(ipl(ivx,ipb1),6,17)-30
- if (iadj .ne. -30) then
- islope(ivx) = islope(ivx)+iadj
- if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx))
- if (nssb(ivx) .gt. 0) then
-c
-c Cycle thru non-rest notes in SSBG, looking for bmstrts.
-c
- isssb = 0
- do 4 inb = 2, nnb
- if (btest(nacc(ivx,ipb(inb)),21)) then
-c
-c Beam segment start. New start level
- isssb = isssb+1
- lev1ssb(ivx,isssb) =
- * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac
- end if
-4 continue
- end if
- end if
- end if
- iadj = igetbits(islur(ivx,ipb1),2,27)
- addbrack = .false.
- if (btest(ipl(ivx,ipb1),30)) then
-c
-c Check for altered starting polarity. Only in forced beams. Nominal start
-c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.).
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'loff{'
- else
- notexq = notexq(1:lnote)//sq//'loff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- else if (ulq(ivx,ibc).eq.'l' .and.
- * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'roff{'
- else
- notexq = notexq(1:lnote)//sq//'roff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- end if
-c
-c Check end level for possible flipping in forced beam. Have to do it
-c here since with multiple voices, xelsk will not be preserved.
-c
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
- else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then
- bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
- end if
- end if
- call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote)
-c
-c Put in name of start level and slope, after correcting nolev1 if xtup
-c started with a rest.
-c
- if (ixrest(ivx).eq.2) nolev1(ivx) =
- * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac)
- call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1))
- if (islope(ivx) .lt. 0) then
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+4+lnoten
- write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}'
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- write(notexq(lnote:lnote),'(i1)')islope(ivx)
- end if
-c
-c Check for beam-thk fine-tuning
-c
- if (iadj .gt. 0) then
- do 1 imp = multb+iadj , multb+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
-1 continue
- end if
-c
-c If we shifted, must close with right bracket
-c
- if (addbrack) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Get 'floor' zmin for figures
-c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height
-c won't be adjusted. If anyone ever needs that, need to duplicate this
-c functionality up above, before exiting.
-c
- if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then
- if (ivx .eq. 1) then
- ivf = 1
- else
- ivf = ivxfig2
- end if
- zmult = 1.2*(multb-1)
- ymin = 100.
- do 3 inb = 1, nnb
- if (isfig(ivf,ipb(inb))) then
- if (ulq(iv,ibc) .eq. 'u') then
- ybot = nolev(iv,ipb(inb))
- else
- ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx)
- * -stemlen-zmult
- end if
- ymin = min(ymin,ybot)
- end if
-3 continue
- maxdrop = ncmid(iv,ipb1)-4-ymin+5.01
- ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop)
- end if
-c
-c Compute ornament levels if needed
-c
- NomOrnLev = ncmid(iv,ipb1)+5
- iorn = 0
- do 8 inb = 1 , nnb
- ip = ipb(inb)
- if (.not.btest(iornq(ivx,ip),23)) go to 8
- if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then
-c
-c letter-dynamic or hairpin ending under down-beamed
-c
- iorn = iorn+1
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- else if (.not.btest(ipl(ivx,ip),10)) then
-c
-c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD
-c
-c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if
-c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.)
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then
- iorn = iorn+1
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- end if
- else
-c
-c In a chord. Orn may be on main note or non-main or both. Set ihornb if
-c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note
-c
- do 10 icrd1 = 1 , ncrd
- if (iand(255,icrdat(icrd1)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11
-10 continue
-11 continue
-c
-c Find outermost note, min or max depending on beam direction ulq. xto is true
-c if there's an ornament on that note. Expand orn list to include ._, since if
-c on extreme chord note in beam, will move.
-c So ornaments are all except 0,4,13 (,g,)
-c
- levx = nolev(ivx,ip)
- xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0
- icrdx = 0
- do 12 icrd = icrd1 , ncrd
- if (iand(255,icrdat(icrd)) .ne. ip .or.
- * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13
- levc = iand(127,ishft(icrdat(icrd),-12))
- if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or.
- * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then
- levx = levc
- icrdx = icrd
- xto = iand(icrdorn(icrd),4186094).gt.0
- end if
-12 continue
-13 continue
-c
-c If there's orn on extreme note, do stuff
-c
- if (xto) then
- iorn = iorn+1
- if (ulq(ivx,ibc) .eq. 'u') then
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- else
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- end if
- if (icrdx .eq. 0) then
-c
-c Affected ornament is on main note
-c
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- else
- icrdorn(icrdx) = ibset(icrdorn(icrdx),22)
- end if
- end if
- end if
-8 continue
-c
-c Henceforth nornb will be a counter.
-c
- if (iorn .gt. 0) nornb(ivx)=1
- if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0
- return
- end
- block data
- parameter (nm=24)
- common /comtol/ tol
- common /comtrans/ cheadq
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- logical usefig
- common /comstart/ facmtr
- character*60 cheadq
- character*120 instrq,titleq,compoq
- logical headlog
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /combmh/ bmhgt,clefend
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
-c
- data tol /.001/
- data cheadq
- * /' '/
- data gslfac /9./
- data instrq,titleq,compoq,headlog /3*' ',.false./
-c
-c meter space (pts) = xb4mbr = musicsize*facmtr
-c
- data facmtr /0.55/
- data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt
- * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 ,
- * .7,.7 ,.9 ,.5 ,2.3 ,1.1 /
- data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac
- * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 /
- data rtshfac / 1.0 /
- data isize /nm*0/
-c
-c From other
-c
- data ptheight,widthpt,
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh
- * / 740. , 524. ,
- * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12.,
- * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 /
- data fracsys /30*0./
- data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1,
-c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3,
- * -0.3,0.3 /
- data kbdrests /.false./,
- * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/
- data EarlyTransOn, LaterInstTrans /2*.false./
- data iInstTrans /nm*0/
- end
- subroutine catspace(space,squez,nnsk)
- parameter (nkb=3999,maxblks=4000)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /comtol/ tol
- logical gotclef
- do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
- if (abs(space-durb(iptr)) .lt. tol) then
- if (abs(squez-sqzb(iptr)) .lt. tol) then
-c
-c Increment pre-existing entry
-c
- nnpd(iptr) = nnpd(iptr)+nnsk
- return
- end if
- end if
-16 continue
-c
-c Didn't find current duration & squez, so add a new entry.
-c No particular reason to keep in order, so add at the end.
-c
- nnpd(nptr(ibarcnt+1)) = nnsk
- durb(nptr(ibarcnt+1)) = space
- sqzb(nptr(ibarcnt+1)) = squez
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- return
- end
- character*1 function chax(n)
-c
-c The only reason for this seemingly do-nothing function is to get around an
-c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler!
-c
- chax = char(n)
- return
- end
- subroutine checkdyn(lineq,iccount,ibar)
- character*128 lineq
- character*1 durq,chax
- character*4 dynsymq
- logical txtdyn
- txtdyn = .false.
-c
-c On entry, iccount is on "D"
-c
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c Dynamic text
-c
- iend = index(lineq(iccount+2:128),'"')
- if (iend .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,
- * 'Dynamic text must be terminated with double quote!')
- call stop1()
- end if
-c
-c Set iccount to character after 2nd ", and set ipm
-c
- iccount = iccount+iend+2
- ipm = index('- +',lineq(iccount:iccount))
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "-", "+", or blank here!')
- call stop1()
- end if
- else
-c
-c Expect ordinary dynamic
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then
- call errmsg(lineq,iend-1,ibar,
- * 'Wrong length for dynamic mark!')
- call stop1()
- end if
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ',
- * dynsymq)+3)/4
- if (idno .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!')
- call stop1()
- end if
- iccount = iend
- end if
- if (ipm .ne. 2) then
-c
-c There is a vertical shift, have "+" or "-"
-c
- iccount = iccount+1
- if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected integer here for vertical offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- if (idno .gt. 63) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Vertical offset for dynamic mark must be (-63,63)!')
- call stop1()
- end if
- ipm = index('- +',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "+", "-", or blank here!')
- call stop1()
- end if
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
- iccount = iccount+1
- if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected number here for horizontal offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- if (idno .gt. 255) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!')
- call stop1()
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,
- * 'There should be a blank here!')
- call stop1()
- end if
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- return
- end
- subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
-c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp,
-c * icashft)
- logical found1,iscacc,isarp,btest
- integer icrdat(193)
- found1 = .false.
-c
-c icashft will be max left shift of accid's in chord notes.
-c Used only for spacing checks.
-c Will include left shift of chord note itself.
-c Rezero after use.
-c
- do 18 icrd = 1 , ncrd
-c
-c This if block cycles thru all chord notes on ivx,ip; then returns.
-c
- if (iand(255,icrdat(icrd)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
- found1 = .true.
- iscacc = iscacc .or.
- * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27))
-c
-c Accid on this chord note, and it's not midi-only.
-c
-c irshft = igetbits(icrdot(icrd),7,20)
-cc
-cc Include increment for notehead shift
-cc
-c if (btest(icrdat(icrd),23)) then
-c if (irshft .eq. 0) then
-c irshft = 44
-c else
-c irshft=irshft-20
-c end if
-c end if
-c if (irshft .ne. 0) then
-cc
-cc Accid on chord note is shifted. Include only left shift, in 20ths.
-cc
-c if (irshft .lt. 64) icashft = max(icashft,64-irshft)
-c end if
-c end if
- isarp = isarp .or. btest(icrdat(icrd),25)
- else if (found1) then
- return
- end if
-18 continue
- return
- end
- subroutine chkimidi(icm)
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- if (imidi(icm) .ge. mv) then
- print*
- print*,'Midi file is too long! It will be corrupted or worse'
- write(*,'(a6,2x,4i8)')
- * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3)
- end if
- return
- end
- subroutine chklit(lineq,iccount,literr)
- character*128 lineq
- character*1 charq,chax
- literr = 0
- itype = 1
-17 call g1etchar(lineq,iccount,charq)
- if (charq .eq. chax(92)) then
- itype = itype+1
-c if (itype .eq. 2) then
-c if (iccount .ne. 2 ) then
-cc
-cc type 2 or 3 tex string not starting in column 1
-cc
-c literr = 3
-c return
-c end if
-c else if (itype .gt. 3) then
- if (itype .gt. 3) then
- literr = 1
- return
- end if
- go to 17
- end if
- lenlit = itype
-18 call g1etchar(lineq,iccount,charq)
- if (charq.eq.chax(92)) then
- call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
-c
-c Starting a new tex command withing the string
-c
- lenlit = lenlit+2
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- else
- lenlit = lenlit+1
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- return
- end
- subroutine chkpm4ac(lineq,iccount,nacc,moved)
-c
-c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>.
-c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits
-c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed
-c numbers. If moved=.true., iccount on exit is on end of last number.
-c If moved=.false., iccount still on +/-
-c
- logical moved,ishorz
- character*128 lineq
- character*1 durq
- if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and.
- * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then
-c
-c Prior char was accid & next is #; this may be start of accidental shift.
-c Must test for "." above in case we get "<" or ">"
-c
- ipm = index('- +< >',lineq(iccount:iccount))-2
- if (lineq(iccount+1:iccount+1).eq.'.' .and.
- * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then
-c
-c Rare case of [accid][+/-].[letter]. Bail out
-c
- moved = .false.
- return
- end if
- ishorz = ipm .gt. 1
-c
-c Save iccount in case it's not accid shift and we have to reset.
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (ishorz .or. index('+-',durq).gt.0) then
-c
-c This has to be accidental shift. Set vert. shift.
-c
- if (.not.ishorz) then
-c
-c +/- syntax, both shifts set, vertical first
-c
- call setbits(nacc,6,4,int(ipm*fnum+32.5))
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else
-c
-c </> syntax, only horiz set
-c
- ipm = ipm-3
- end if
-c
-c Set horiz. shift
-c
- call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35)))
- iccount = iccount-1
- moved = .true.
- else
-c
-c False alarm. Reset everything and flow onward
-c
- moved = .false.
- iccount = icsav
- end if
- else
-c
-c Either prior char was not 'sfn' or next was not digit, so take no action
-c
- moved = .false.
- end if
- return
- end
- subroutine clefsym(isl,notexq,lnote,nclef)
-c
-c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs.
-c
- character*(*) notexq
- character*1 chax
- nclef = iand(ishft(isl,-12),7)
- if (nclef .eq. 0) then
-c
-c treble
-c
- nlev = 2
- else if (nclef .gt. 6) then
-c
-c French violin
-c
- nlev = 0
- else if (nclef .lt. 5) then
-c
-c C-clef
-c
- nlev = 2*nclef-2
- else
-c
-c F-clef
-c
- nlev = 2*nclef-6
- end if
- notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7))
- * //chax(48+nlev)
- lnote = 10
- return
- end
- subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c micrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c segrb(1|2,.) x|y-coord of right-bdry segment
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c icrdot0 = top-down level-rank of main note among accid-notes
-c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes
-c twooftwo will be true 2nd time thru; signal to store shifts w/ notes
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50)
- integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50),
- * isetshft(10),ksegrb0(50)
- logical lasttime,mainnote,twooftwo
- data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 /
- data segar /
-c
-c Fancy sharp boundary. fl,sh,na,dfl,dsh
-c
- * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2,
-c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. ,
-c meas value for y, natural is 1.6
- * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2,
- * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
- data segal /
-c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. ,
-cc (meas. value is 3.08) ^^^^
-cc Raise top of flat so it interferes with bottom of sharp
- * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2,
- * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2,
- * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
-c
-c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6)
-c
- data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 /
-c
-c Set up barrier segrb(iseg,ipoint) to define coords of corner points
-c on stem+notes
-c
- do 11 iseg = 1 , nsegrb0
- segrb(1,iseg) = segrb0(1,iseg)
- segrb(2,iseg) = segrb0(2,iseg)
- ksegrb(iseg) = ksegrb0(iseg)
-11 continue
- nsegrb = nsegrb0
- rmsshift = 0.
- shiftmin = 1000.
- do 1 iwa = 1 , naccid
-c
-c Initialize shift for this note
-c
- shift = 0.
- mainnote = micrd(iwa).eq.0
- isetshft(iwa) = -1
-c
-c Get note level and accidental type
-c
- if (mainnote) then
- nolev = nolevm
- iacctype = iacctbl(igetbits(nacc,3,0))
- else
- nolev = igetbits(icrdat(micrd(iwa)),7,12)
- iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20))
- end if
-c
-c Cycle thru segments on right edge of this accidental
-c
- do 2 isega = 1 , nsegar(iacctype)-1
- ybotaseg = nolev+segar(iacctype,2,isega)
- ytopaseg = nolev+segar(iacctype,2,isega+1)
-c
-c Cycle thru segments of right-hand barrier
-c
- do 3 isegrb = 1 , nsegrb-1
-c
-c Must find all barrier segments that start below ytopseg & end above ybotseg
-c
- if (segrb(2,isegrb) .lt. ytopaseg) then
-c
-c Barrier seg starts below top of accid
-c Check if barrier seg ends above bottom of accid
-c
- if (segrb(2,isegrb+1) .gt. ybotaseg) then
- if (shift .gt.
- * segrb(1,isegrb)-segar(iacctype,1,isega)) then
- shift = segrb(1,isegrb)-segar(iacctype,1,isega)
-c
-c Record the cause of the shift
-c
- isetshft(iwa) = ksegrb(isegrb)
- end if
- end if
-c
-c Does barrier segment end above top of accid seg?
-c
- if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4
- end if
-3 continue
-4 continue
-2 continue
- if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001
- * .and. .not.lasttime) then
-c if (nolev .eq. levmaxacc) then
- if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then
- rmsshift = 1000.
- return
- end if
-c
-c Does the following properly account for left-shifted noteheads?
-c
-c Top-down rank of this note we just shifted
-c
- if (mainnote) then
- irank = icrdot0
- else
- irank = igetbits(icrdot(micrd(iwa)),3,27)
- end if
-c
-c Compare level-rank of this note vs. that of note that caused the shift.
-c This has effect of checking for basic interferences from top down.
-c
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c
- if (isetshft(iwa) .lt. 0) then
- iranksetter = 0
- else if (isetshft(iwa) .eq. 0) then
- iranksetter = icrdot0
- else
- iranksetter = igetbits(icrdot(isetshft(iwa)),3,27)
- end if
- if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then
- rmsshift = 1000.
- return
- end if
- end if
- rmsshift = rmsshift+shift**2
- if (lasttime .and. abs(shift).gt..0001) then
- if (mainnote) then
- if (.not.btest(nacc,29)) go to 10
- else
- if (.not.btest(icrdat(micrd(iwa)),29)) go to 10
- end if
-c
-c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there
-c was a manual shift but auto-shift was zero, will not come thru here, but shift value
-c will be left intact.
-c
- if (mainnote) then
- shift = shift+.05*(igetbits(nacc,7,10)-107)
- else
- shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107)
- end if
-10 continue
- if (twooftwo) then
-c
-c Record the shift for this accidental
-c
- if (shift .lt. -5.35) then
- call printl(' ')
- call printl('WARNING: auto-generated accidental '//
- * 'shift too big for PMX, ignoring')
- else
- ishift = nint(20*(shift+5.35))
- if (mainnote) then
- call setbits(nacc,7,10,ishift)
- else
- call setbits(icrdot(micrd(iwa)),7,20,ishift)
- end if
- end if
- else
-c
-c This is the earlier call to precrd, so need minimum shift
-c
- shiftmin = min(shiftmin,shift)
- end if
- end if
-c
-c Bail out if this is the last accidental to check
-c
- if (iwa .eq. naccid) go to 1
-c
-c Add this accidental to the right barrier! Count down from highest barrier segment,
-c find 1st one starting below top of accid, and first one starting below bot.
-c
- do 5 ibelowtop = nsegrb , 1 , -1
- if (segrb(2,ibelowtop) .lt.
- * nolev+segal(iacctype,2,nsegal(iacctype))) then
- do 9 ibelowbot = ibelowtop , 1 , -1
- if (segrb(2,ibelowbot) .lt.
- * nolev+segal(iacctype,2,1)) go to 6
-9 continue
- print*,'Oops2!'
- call stop1()
- end if
-5 continue
- print*,'Ugh0! in crdaccs'
- call stop1()
-6 continue
- netgain = nsegal(iacctype)-ibelowtop+ibelowbot
-c
-c Shift high segments up
-c
- if (netgain .ge. 0) then
- do 7 isegrb = nsegrb , ibelowtop+1 , -1
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-7 continue
-c
-c Set up 1st segment above accid
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- else
-c
-c netgain<0, must remove segments. Use same coding but reverse order,
-c work from bottom up
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- do 12 isegrb = ibelowtop+1 , nsegrb
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-12 continue
- end if
-c
-c Insert new segments
-c
- do 8 isega = 1 , nsegal(iacctype)-1
- segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega)
- segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega)
- if (mainnote) then
- ksegrb(ibelowbot+isega) = 0
- else
- ksegrb(ibelowbot+isega) = micrd(iwa)
- end if
-8 continue
-c
-c Update number of barrier segments
-c
- nsegrb = nsegrb+netgain
-cc
-cc Temporary printout for boundary segments as built up
-cc
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa)
-cc
-1 continue ! next accidental
- if (lasttime .and. .not.twooftwo) then
-c
-c This is the final call on the pre-ask pass, so compute left-shift rqmt.
-c
- icashft = nint(-20*shiftmin)
- end if
-cc
-cc Temporary printout for boundary segments
-cc
-c if (twooftwo) then
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa),isetshft(iwa),iwa=1,naccid)
-c end if
-cc
- return
- end
- subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm,
- * levmaxacc,levminacc,icrdot0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c
-c This is called once per multi-accidental chord. In here, loop over all
-c permutations of the order of accidental as stored in kicrd. Each time thru
-c loop, call crdacc once, get rms shift. Only save permutation and rms value
-c if it is less than old value.
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c Make consistent? 120106
-c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- real*4 segrb0(2,50)
- logical btest,tagged,manual,lshift,twooftwo
-cc
-cc Temporary printout of level-rankings
-cc
-c write(15,'()')
-c do 98 iacc = 1 , naccid
-c if (kicrd(iacc) .eq. 0) then
-c write(15,'(3i5)')nolevm,icrdot0
-c else
-c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12),
-c * igetbits(icrdot(kicrd(iacc)),3,27)
-c end if
-c98 continue
-cc
-c
-c Initialize right-barrier
-c
- segrb0(1,1) = 0.
- segrb0(2,1) = -1000.
- segrb0(1,2) = 0.
- segrb0(2,2) = 1000.
- nsegrb0 = 2
- ksegrb0(1) = -1
- ksegrb0(2) = -1
-c
-c Search for left-shifted notes, Make up the initial right-barrier, which
-c will be good for all permutations.
-c irest()(27) is set if any notes are left-shifted
-c Must use ALL chord notes, not just ones w/ accid's.
-c
- if (btest(irest,27)) then
- do 15 icrd = icrd1-1, icrd2
- if (icrd .eq. icrd1-1) then
-c
-c Main note
-c
-c lshift = btest(ipl,8)
- lshift = btest(ipl,8) .or. btest(nacc,31)
- if (lshift) nolev = nolevm
- else
-c
-c Chord note
-c
- lshift = btest(icrdat(icrd),23)
-c if (lshift) nolev = igetbits(icrdat(icrd),7,12)
- if (lshift) then
- nolev = igetbits(icrdat(icrd),7,12)
- if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
-c
-c This note is not really shifted, It is the upper of a 2nd with the main
-c note on an upstem, and Main note must be shifted.
-c nacc(31) signals the real truth.
-c
- lshift = .false.
- end if
- end if
- end if
- if (lshift) then
- do 16 isegrb = 1 , nsegrb0-1
- if (segrb0(2,isegrb+1) .gt. nolev-1) then
-c
-c Add this notehead to the right boundary here. Move all higher segs up 2.
-c
- do 17 iiseg = nsegrb0 , isegrb+1 , -1
- segrb0(1,iiseg+2) = segrb0(1,iiseg)
- segrb0(2,iiseg+2) = segrb0(2,iiseg)
- ksegrb0(iiseg+2) = ksegrb0(iiseg)
-17 continue
- go to 18
- end if
-16 continue
-18 continue
-c
-c Insert notehead into list. Set kseg=-2 to signal notehead shift.
-c
- iiseg = isegrb+1
- segrb0(1,iiseg) = -1.2
- segrb0(2,iiseg) = nolev-1.
- ksegrb0(iiseg) = -2
- segrb0(1,iiseg+1) = 0.
- segrb0(2,iiseg+1) = nolev+1.
- ksegrb0(iiseg+1) = -1
- nsegrb0 = nsegrb0+2
- end if
-15 continue
- end if
-c
-c Done setting right barrier for left-shifted noteheads
-c
- tagged = .false.
- manual = .false.
-c
-c Preprocess to check for manual shifts.
-c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then
-c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts, Observe all manual shifts.
-c End if
-c End if
-c
- maxmanshft = 0
- do 13 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
-c
-c Main note
-c
- manshft = igetbits(nacc,7,10)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(nacc,29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- else
-c
-c Chord note
-c
- manshft = igetbits(icrdot(kicrd(i)),7,20)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(icrdat(kicrd(i)),29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- end if
-13 continue
- if (manual) then
- if (tagged) then
-c
-c zero out all untagged shifts
-c
- do 14 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
- if (.not.btest(nacc,29)) call setbits (nacc,7,10,0)
- else
- if (.not.btest(icrdat(kicrd(i)),29))
- * call setbits (icrdot(kicrd(i)),7,20,0)
- end if
-14 continue
- else
-c
-c There are manual shifts but none tagged. Only proceed if "Ao" was entered
-c
- if (.not.btest(nacc,28)) then
- icashft = maxmanshft
- return
- end if
- end if
- end if
- if (btest(nacc,28)) then
-c
-c Take the accidentals in order as originally input, then exit.
-c
- call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
-c end if
- else if (naccid .eq. 3) then
-c
-c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd
-c then place in order top, bottom, middle.
-c
- do 20 i = 1 , 3
- if (kicrd(i) .eq. 0) then
- irank = icrdot0
- nolev = nolevm
- else
- irank = igetbits(icrdot(kicrd(i)),3,27)
- nolev = igetbits(icrdat(kicrd(i)),7,12)
- end if
- if (irank .eq. 1 ) then
- micrd(1) = kicrd(i)
- else
- micrd(5-irank) = kicrd(i)
- end if
- if (irank .eq. 2) then
- levmidacc = nolev
- end if
-20 continue
- if (levmaxacc.ne.levmidacc+1 .and.
- * levmidacc.ne.levminacc+1) then
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end if
- end if
- rmsmin = 100000.
-c
-c Initialize permutation array
-c
- do 7 i = 1 , naccid
- iperm(i) = i
-7 continue
-c
-c Start looping over permutations
-c
- do 8 ip = 1 , 5041
- if (ip .ne. 1) then
-c
-c Work the magic algorithm to get the next permutation
-c
- do 1 k = naccid-1 , 1 , -1
- if (iperm(k) .le. iperm(k+1)) go to 2
-1 continue
-c
-c If here, we just got the last permutation, so exit the loop over permutations
-c
- go to 10
-2 continue
- do 3 j = naccid , 1 , -1
- if (iperm(k) .le. iperm(j)) go to 4
-3 continue
-4 continue
- it = iperm(j)
- iperm(j) = iperm(k)
- iperm(k) = it
- is = k+1
- do 5 ir = naccid , 1 , -1
- if (ir .le. is) go to 6
- it = iperm(ir)
- iperm(ir) = iperm(is)
- iperm(is) = it
- is = is+1
-5 continue
-6 continue
- end if
-c
-c New we have a permutation. Take icrd values out of kicrd and put them into
-c micrd in the order of the permutation
-c
- do 9 i = 1 , naccid
- micrd(i) = kicrd(iperm(i))
-9 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false.,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-cc
-cc Temporary printout
-cc
-c write(15,*)'perm done, rmsshift:',rmsshift
-cc
- if (rmsshift .lt. rmsmin) then
-c
-c Save this permutation, reset minrms
-c
- do 11 i = 1 , naccid
- ipermsav(i) = iperm(i)
- rmsmin = rmsshift
-11 continue
- end if
-8 continue
- print*,'Should not BEEEEEE here!'
- call stop1()
-10 continue
-c
-c Done looping, get info for the final choice
-c
- do 12 i = 1 , naccid
- micrd(i) = kicrd(ipermsav(i))
-12 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end
- subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut)
- character*1 sq,chax
- character*3 acsymq
- character*8 noteq
- character*79 notexq
- logical btest,caut
- sq = chax(92)
- if (ihshft .eq. -107) ihshft=0
-cc
-cc If main note shifted left, so shift accid. Terminate below, when acc. is done.
-cc
- if (ihshft .ne. 0) then
-c
-c Accid must be shifted horizontally
-c
- if (ihshft .lt. 0) then
- notexq = sq//'loffset{'
- ihshft = -ihshft
- else
- notexq = sq//'roffset{'
- end if
- hshft = .05*ihshft
- if (hshft .lt. 1.) then
- write(notexq(10:12),'(f3.2)')hshft
- lnote = 12
- else
- write(notexq(10:13),'(f4.2)')hshft
- lnote = 13
- end if
- notexq = notexq(1:lnote)//'}{'//sq
- lnote = lnote+3
- else
- notexq = sq
- lnote = 1
- end if
- if (btest(nacc,3)) then
- notexq = notexq(1:lnote)//'big'
- lnote = lnote+3
- end if
- if (caut) then
-c
-c Cautionary accidental. Need to define bigcna,... in pmx.tex
-c
- notexq = notexq(1:lnote)//'c'
- lnote = lnote+1
- end if
- call accsym(nacc,acsymq,lacc)
- notexq = notexq(1:lnote)//acsymq(1:lacc)
- lnote = lnote+lacc
- noleva = nolev
- if (ivshft .ne. 0) noleva = noleva+ivshft-32
- call notefq(noteq,lnoten,noleva,ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihshft .ne. 0) then
-c
-c Terminate horizontal shift
-c
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt,
- * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen,
- * dotxtup,nacc)
- parameter (nm=24,mv=24576)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical lowdot,dotxtup
- integer*4 ihornb(nm,24),nornb(nm)
- character*1 ulq(nm,9),chax
- character*7 nosymq
- character*8 noteq
- character*79 notexq,outq
- character*80 soutq
- logical btest,isleft,isright,beamon
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
-c
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c
-c This subr. once produced notexq for entire chord. 10/18/97 altered to write
-c chord notes as we go. 10/22/97 find range of icrd first.
-c 2/25/98 moved rangefinding to precrd so done before slurs, so now
-c on entry, icrd1, icrd2 define range of icrd for this chord.
-c
-c Set counter (for this note) for chord notes present. Set notmain=T.
-c Will test for notmain=.true. in addmidi to tell whether to save pitch.
-c
- nmidcrd = 0
- notmain = .true.
- crdacc = .false.
- do 5 icrd = icrd1 , icrd2
- lnote = 0
- nolev = igetbits(icrdat(icrd),7,12)
-c
-c 3/8/03 save original pitch to use in midi, in case 2nds alter things.
-c
- nolevo = nolev
-c
-c Check for special situations with 2nds (see precrd).
-c
- if (btest(nacc,30)) then
- if (nolev .eq. nolevm-1) nolev = nolevm
- else if (btest(nacc,31)) then
- if (nolev .eq. nolevm+1) nolev = nolevm
- end if
-c
-c Lower dot for lower-voice notes?. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest (cannot be a rest in a chord!)
-c. 5. Flag (lowdot) is set to true
-c
- if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then
- if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then
- if (btest(icrdat(icrd),26)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- call setbits(icrdot(icrd),7,0,
- * igetbits(icrdot(icrd),7,0)-20)
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3))
- end if
- end if
- end if
- if (btest(icrdat(icrd),26)) then
-c
-c Move the dot.
-c
- updotc = 0.1*(iand(127,icrdot(icrd))-64)
- rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
- call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3))
- end if
- isleft = btest(icrdat(icrd),23)
- isright = btest(icrdat(icrd),24)
-c
-c Check for ornament in chord.
-c
- if (icrdorn(icrd) .gt. 0) then
- call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
- * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
- * ip,0,beamon,.true.)
-c
-c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
-c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt,
-c * notcrd,beamon,iscrd)
-c
- call addstr(outq,lout,soutq,lsout)
- end if
-c
-c Chord-note symbol. First check for breve
-c
- if (nodu .eq. 128) then
- nosymq = chax(92)//'zbreve'
- lsym = 7
- else
-c
-c Not a breve chord. Get first letters in chord-note symbol
-c
- if (isleft) then
- nosymq = chax(92)//'l'
- else if (isright) then
- nosymq = chax(92)//'r'
- else
- nosymq = chax(92)//'z'
- end if
- if (nodu .ge. 64) then
- nosymq = nosymq(1:2)//'w'
- else if (nodu .ge. 32) then
- nosymq = nosymq(1:2)//'h'
- else
- nosymq = nosymq(1:2)//'q'
- end if
- if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then
- lsym = 3
- else if (.not.btest(islur,3) .or. dotxtup) then
-c
-c Single dot
-c
- nosymq = nosymq(1:3)//'p'
- lsym = 4
- else
-c
-c Double dot
-c
- nosymq = nosymq(1:3)//'pp'
- lsym = 5
- end if
- end if
- if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then
-c
-c Accidental and not MIDI-only. Build up bits 0-3 of nacc
-c
- nactmp = igetbits(icrdat(icrd),3,20)
-c
-c Kluge for bigness. Only means 'As' has not been issued
-c
- if (bacfac .ne. 1.e6) nactmp = nactmp+8
- call doacc(igetbits(icrdot(icrd),7,20)-107,
- * igetbits(icrdot(icrd),6,14),
-c * notexq,lnote,nactmp,nolev,ncmid(iv,ip))
-c Get original nolev, not altered to deal with 2nds
- * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12),
-c * ncmid(iv,ip))
- * ncmid(iv,ip),btest(icrdat(icrd),31))
- notexq = notexq(1:lnote)//nosymq
- crdacc = .true.
- else
- notexq = nosymq
- end if
- lnote = lnote+lsym
-c
-c Get note name (again if accid, due to possible octave jump)
-c
- call notefq(noteq,lnoten,nolev,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
-c
-c Put in note name
-c
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- if (btest(icrdat(icrd),25)) then
-c
-c Arpeggio signal
-c
-c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout)
- call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout)
- end if
- call addstr(notexq,lnote,soutq,lsout)
- if (ismidi) then
-c
-c Here is where we collect MIDI pitch info for the chord note. By checking
-c notmain, addmidi(...) knows to just compute the
-c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi()
-c for MAIN note, will put in note codes for all chord notes + main note.
-c
- kv = 1
- if (ivx .gt. iv) kv=2
- nmidcrd = nmidcrd+1
- if (nmidcrd .gt. 20) then
- print*
- print*,'21 chord notes is too many for midi processor'
- call stop1()
- end if
-c
-c Use original saved pitch level, unaltered by 2nds logic.
-c
-c call addmidi(midchan(iv,kv),nolevo,
- call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)),
- * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.)
- end if
-5 continue
- notmain = .false.
- return
- end
- subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv,
- * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout)
- parameter (nm=24)
-c
-c Inputs are array *elements* except ihornb,nornb,ulq
-c
- common /commus/ musize,whead20
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,beamon,upstem,nostem
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 udqq,chax,ulq(nm,9)
- character*4 dynstrq
- character*5 numpq
- character*48 dyntablq,tempq
- character*79 notexq
- character*80 soutq
- integer*4 ihornb(nm,24),nornb(nm),idynn(10)
- data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/
- numdyn = 0
-c
-c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values
-c in idynn(1...4)
-c
- do 1 idyn = 1 , ndyn
-c ivxtent = iand(idyndat(idyn),15)
- ivxtent = iand(idyndat(idyn),15)
- * +16*igetbits(idynda2(idyn),1,10)
- if (ivxtent .eq. ivx) then
- iptent = igetbits(idyndat(idyn),8,4)
- if (iptent .eq. ip) then
- numdyn = numdyn+1
- idynn(numdyn) = idyn
- else if (iptent .gt. ip) then
-c
-c I don't think there are any more possible for this ivx,ip, so exit loop
-c
- go to 2
- end if
-c else if (ivxtent .gt. ivx) then
-c go to 2
- end if
-1 continue
-2 continue
-c
-c At this point there is a list of idyn's in idynn(1...numdyn)
-c Compute level, and stem-dir'n-based horizontal tweaks
-c
- hoffsd = 0.
-c
-c Set upstem to false as default
-c
- upstem = .false.
- if (btest(irest,0)) then
-c
-c It's a rest. Assume it doesn't go below the staff
-c
- lbot = ncm-4
- else if (.not.beamon) then
- if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-7,ncm-4)
- else
- lbot = min(minlev-7,ncm-4)
- end if
- end if
- else
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
- lbot = ihornb(ivx,nornb(ivx))+1
- if (lbot .eq. 1) then
-c
-c Kluge for non-beamed, down xtup, for which ihorb was never set.
-c Assumes stem is shortened.
-c
- lbot = nolev-5
- end if
- nornb(ivx) = nornb(ivx)+1
- end if
- end if
- lbot = lbot-5
- jtxtdyn1 = 1
-c
-c Now ready to loop over current dyn's
-c
- do 3 icntdyn = 1 , numdyn
- idynd = idyndat(idynn(icntdyn))
- idynd2 = idynda2(idynn(icntdyn))
- idno = igetbits(idynd,4,12)
-c ivx = iand(15,idynd)
- ivx = iand(15,idynd)+16*igetbits(idynd2,1,10)
-c
-c Build the command into notex in stages. Insert name & rq'd args in order:
-c
-c Command name
-c hpstrt, hpcend, hpdend, pmxdyn
-c ivx
-c X X X
-c level
-c X X X
-c hoff
-c X X X X
-c d-mark
-c X
-c
- if (idno .eq. 0) then
-c
-c Text-dynamic
-c
- notexq = chax(92)//'txtdyn'
- lnote = 7
- else if (idno .le. 12) then
-c
-c Letter-group
-c
- notexq = chax(92)//'pmxdyn'
- lnote = 7
- else if (fontslur) then
- lnote = 7
- if (idno .eq. 13) then
-c
-c Start a hairpin
-c
- notexq = chax(92)//'hpstrt'
- else if (idno .eq. 14) then
-c
-c End crescendo
-c
- notexq = chax(92)//'hpcend'
- else
-c
-c End decrescendo
-c
- notexq = chax(92)//'hpdend'
- end if
- else
-c
-c Postscript hairpins
-c
- lnote = 7
- if (idno .eq. 13) then
- notexq = chax(92)//'Icresc'
- else if (idno .eq.14) then
- notexq = chax(92)//'Idecresc'
- lnote = 9
- else
- notexq = chax(92)//'Tcresc'
- end if
- end if
- if (idno .ge. 13) then
-c
-c Put in voice number
-c
- if (ivx .le. 9) then
- notexq = notexq(1:lnote)//char(48+ivx)
- lnote = lnote+1
- else if (ivx .le. 19) then
- notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}'
- lnote = lnote+4
- end if
- end if
-c
-c Begin setting level
-c
- lbot1 = lbot
- if (idno.gt.0 .and. idno.le.5) then
-c
-c All letters are short so raise a bit.
-c
- lbot1 = lbot1+1
- else if (idno .ge. 13) then
- lbot1 = lbot1+2
- end if
-c
-c Convert so reference is bottom line
-c
- lbot1 = lbot1-ncm+4
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start. Save level and user-tweak before applying user tweak.
-c
- levdsav(ivx) = lbot1
- levhssav(ivx) = 0
- if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17)
- else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then
-c
-c Hairpin end; Compare level with saved start level before user-tweaks
-c
- lbot1 = min(lbot1,levdsav(ivx))
-c
-c Save pre-tweak level
-c
- lpretweak = lbot1
- end if
-c
-c Check for user-defined vertical tweak
-c
- if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17)
-c
-c Now horizontal stuff
-c
- hoff = hoffsd
-c
-c Some special horizontal tweaks
-c
- if (upstem .and. idno.gt.0 .and.
- * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4
-c
-c User-defined tweaks
-c
- if (btest(idynd2,0))
- * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1
- if (numdyn .gt. 1) then
-c
-c Horizontal-interaction-based tweaks.
-c
-c Cases:
-c numdyn type1 type2 type3 data used
-c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12)
-c 2 hrpnend wrd-grp - ivowg,hoh2
-c 2 hrpnend hrpnstrt - hoh2h1(1...2)
-c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1
-c
- if (idno.gt.0 .and. idno.le.12) then
-c
-c Word-group, may need vertical tweak to line up.
-c
- lbot1 = lbot1+ivowg(idno)
-c
-c Protecting against hp start-stop on same note
-c
- else if (((fontslur.and.idno.ge.14).or.idno.eq.15)
- * .and. icntdyn.lt.numdyn) then
-c
-c Hairpin ending, check next type
-c
- if ((fontslur .and.
- * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or. (.not.fontslur .and.
- * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or.
- * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14))))
- * then
-c
-c Hairpin end then hairpin start, no words, (remember dealing with end now)
-c
- hoff = hoff+hoh2h1(1)
- else
-c
-c Hairpin end then word-group, need idno for w-g to set hp offset
-c
- hoff = hoff +
- * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12))
- end if
-c
-c Protecting against hp start-stop on same note
-c
- else if (icntdyn.gt.1 .and. idno.gt.0 .and.
- * ((fontslur.and.idno.lt.14).or.
- * (.not.fontslur.and.idno.lt.15))) then
-c
-c Hairpin start, check prior type
-c
- if ((fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14)
- * .or.
- * (.not.fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15))
- * then
-c
-c Hairpin end then hairpin start, (remember dealing with start now)
-c
- hoff = hoff+hoh2h1(2)
- else
-c
-c Hairpin start after word-group, need idno for w-g to set hp offset
-c
- hoff = hoff+
- * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12))
- end if
- end if
- end if
-c
-c End of if-block for 2- or 3-way interactions.
-c
- if ((.not.fontslur) .and. idno.ge.13)
-c
-c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width
-c
- * hoff = (hoff+.5)*6./2.5
-c
-c Position corrections all done now. Put in the level.
-c
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start.
-c
- if (.not.fontslur) then
-c
-c Postscript hairpin start...inset placeholder for start level.
-
- notexq = notexq(1:lnote)//'{ }'
- lnote = lnote+5
- end if
- else
-c
-c Insert actual level in all cases except hairpin start
-c Create string with level in it
-c
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Level has now been computed and stored in numpq
-c Append the level
-c
- notexq = notexq(1:lnote)//numpq(1:lnumpq)
- lnote = lnote+lnumpq
- end if
- if (abs(hoff) .lt. .001) then
-c
-c No horiz offset
-c
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
-c
-c Horizontal tweak
-c
- lform = lfmt1(hoff)
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')hoff
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- if (idno .eq. 0) then
-c
-c text-dynamic. Find the string and append it
-c
- do 4 jtxtdyn = jtxtdyn1 , ntxtdyn
-c ivxip = ivx+16*ip
- ivxip = ivx+32*ip
- if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5
-4 continue
- call printl('Abnormal stop in putdyn')
- call stop1()
-5 continue
- ltxtdyn = lenstr(txtdynq(jtxtdyn),128)
-c
-c Font size based on musicsize
-c
- if (musize .eq. 20) then
- notexq = notexq(1:lnote)//'{'//char(92)//'medtype'
- * //char(92)//'it '
- lnote = lnote+13
- else if (musize .eq. 16) then
- notexq = notexq(1:lnote)//'{'//char(92)//'normtype'
- * //char(92)//'it '
- lnote = lnote+14
- else if (musize .eq. 24) then
- notexq = notexq(1:lnote)//'{'//char(92)//'bigtype'
- * //char(92)//'it '
- lnote = lnote+13
- else if (musize .eq. 29) then
- notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype'
- * //char(92)//'it '
- lnote = lnote+13
- end if
- notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn)
- * //'}'
- lnote = lnote+ltxtdyn+1
-c
-c Reset jtxtdyn1 just in case >1 txtdyn on same note.
-c
- jtxtdyn1 = jtxtdyn+1
- else if (idno .le. 12) then
-c
-c Letter-group dynamic. Append the letter-group command
-c
- id = 4*idno
- dynstrq = dyntablq(id-3:id)
- id = lenstr(dynstrq,4)
- notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id)
- lnote = lnote+1+id
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- if ((.not.fontslur).and.idno.eq.15) then
-c
-c PS slurs on, hairpin is ending. Go back and set height at beginning.
-c Add user-defined tweak to default level
-c
- lbot1 = lpretweak+levhssav(ivx)
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Construct string to search backwards for placeholder
-c
- if (ivx .le. 9) then
- tempq = 'cresc'//char(48+ivx)//'{ }'
- ltemp = 11
- else if (ivx .le. 19) then
- tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }'
- ltemp = 14
- else
- tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }'
- ltemp = 14
- end if
- write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- call backfill(11,tempq,ltemp,
- * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq)
- end if
-3 continue
-c
-c Shrink arrays, decrease ndyn 111109
-c
- do 6 icntdyn = numdyn, 1 , -1
- do 7 jdyn = idynn(icntdyn) , ndyn-1
- idyndat(jdyn) = idyndat(jdyn+1)
- idynda2(jdyn) = idynda2(jdyn+1)
-7 continue
- ndyn = ndyn-1
-6 continue
- end
- subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl,
- * farend,
- * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq)
-c
-c ip will be one LESS than current note, for way-after's before bar-end,
-c It is only used to find ig.
-c ig is returned to makeabar in case there's a slur that needs to be ended
-c
- parameter (nm=24)
- logical beamon,stemup
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
- * normsp,farend,fontslur,WrotePsslurDefaults
- real*4 ptgr(37)
- character*80 soutq
- character*128 litq
- character*79 notexq
- character*20 voltxtq
- character*10 figq
- character*8 noteq,noteqGA
- character*3 acsymq
- character*1 sq,chax,udqq,ulq(nm,9)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- sq = chax(92)
- isgaft = btest(ipl,29)
- iswaft = btest(ipl,31)
- normsp = .not. isgaft
-c
-c Find ig.
-c
- do 120 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121
-120 continue
- print*,'Problem finding grace index in dograce'
- stop
-121 continue
- ngs = ngstrt(ig)
- mg = multg(ig)
- wheadpt1 = wheadpt*fullsize(ivx)
-c
-c For way-after-graces at end of bar, must set the octave.
-c
- if (farend) then
- noctup = 0
- if (ncm .eq.23) noctup = -2
- end if
- if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then
- if (listslur .eq. 16777215) then
- print*
- print*,'You defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Slur on fore-grace. Get index of next slur not in use, from 23 down.
-c
- ndxslur = log2(16777215-listslur)
-
- end if
- if (nng(ig) .eq. 1) then
-c
-c Single grace.
-c
- if (normsp) then
-c
-c Anything but GA
-c
- call addstr(sq//'shlft',6,soutq,lsout)
- niptgr = nint(ptgr(ig))
-c
-c Empirical tweak for postscript.
-c
-C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3)
-c++
- if (niptgr .lt. 10) then
- call addstr(chax(48+niptgr)//'{',2,soutq,lsout)
- else if (niptgr .lt. 100) then
- write(notexq(1:2),'(i2)')niptgr
- call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout)
- else
- print*,
- * 'Call Dr. Don if you really want grace note group > 99 pt'
- stop
- end if
- else
- call addstr(sq//'gaft{1.5}{',11,soutq,lsout)
-c
-c GA. Compute aftshft, for later use.
-c
- aftshft = grafac
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac
- aftshft = aftshft*wheadpt
- end if
- if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then
-c
-c Start slur on pre-grace. No accounting needed since will be ended very soon.
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Start Postscript slur.
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print slur number, 23-ndxslur
-c
- lnote = 0
- if (23-ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = chax(71-ndxslur)
- lnote = 1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = '{1'//chax(61-ndxslur)//'}'
- lnote = 4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = 4
- end if
-c if (11-ndxslur .lt. 10) then
-c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten,
-c * soutq,lsout)
-c else
-c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
-c * 4+lnoten,soutq,lsout)
-c end if
- call addstr(notexq(1:lnote)//noteq(1:lnoten),
- * lnote+lnoten,soutq,lsout)
- if (.not.fontslur) then
-c
-c Horizontal tweaks for postscript slur on single grace
-c
- stemup = .true.
- if (upg(ig)) then
-c
-c Check for up-grace + down stem. Get stem direction
-c
- if (.not.beamon) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev,ncmidx,
- * islur,nvmx,ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or. tnote.gt.63
- end if
- if (stemup) then
- call addstr('{-.3}',5,soutq,lsout)
- else
- call addstr('{-.8}',5,soutq,lsout)
- end if
- end if
- end if
- if (naccg(ngs) .gt. 0) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
-c Save for checking octave shifts in GA
-c
- if (isgaft) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)//
- * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
- if (slashg(ig)) then
- notexq = sq//'grc'
- lnote = 4
- else if (mg .eq. 0) then
- notexq = sq//'zq'
- lnote = 3
- else
- notexq = sq//'zc'
- do 61 i = 2 , mg
- notexq = notexq(1:i+1)//'c'
-61 continue
- lnote = mg+2
- end if
- if (upg(ig)) then
- notexq = notexq(1:lnote)//'u'
- else
- notexq = notexq(1:lnote)//'l'
- end if
- call addstr(notexq,lnote+1,soutq,lsout)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
- if (isgaft .and. naccg(ngs).eq.0) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call addstr(noteq,lnoten,soutq,lsout)
- if (slashg(ig)) call addstr(sq//'off{-'//sq//
- * 'noteskip}',16,soutq,lsout)
-c
-c Above code needed since slashg causes spacing
-c
- if (slurg(ig) .and. (iswaft.or.isgaft)) then
-c
-c Terminate slur on single after-grace
-c
-c ndxslur = igetbits(ipl,4,23)
- ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-cc Print 11-ndxslur
-c Print 24-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c call addstr(chax(59-ndxslur)//noteq(1:lnoten),
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
-c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
- slurg(ig) = .false.
- listslur = ibclr(listslur,ndxslur)
- end if
- call addstr('}',1,soutq,lsout)
-c
-c+++ Try to fix loss of octave with single gaft
-c
-c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}',
-c * 13+lnoten,soutq,lsout)
- if (isgaft) then
- itrans = 0
- do 1 i = 1 , lnotenGA
- if (noteqGA(i:i) .eq. chax(39)) then
- itrans = itrans+7
- else if (noteqGA(i:i) .eq. chax(96)) then
- itrans = itrans-7
- end if
-1 continue
- if (itrans. eq. -14) then
- call addstr(sq//'advance'//sq//'transpose-14',21,
- * soutq,lsout)
- else if (itrans .eq. -7) then
- call addstr(sq//'advance'//sq//'transpose-7',20,
- * soutq,lsout)
- else if (itrans .eq. 7) then
- call addstr(sq//'advance'//sq//'transpose7',19,
- * soutq,lsout)
- else if (itrans .eq. 14) then
- call addstr(sq//'advance'//sq//'transpose14',20,
- * soutq,lsout)
- end if
- end if
- else
-c
-c Multiple grace. Put in literally. Compute beam stuff
-c
- sumx = 0.
- sumy = 0.
- sumxy = 0.
- sumxx = 0.
- sumyy = 0.
- x = 0.
- do 118 ing = ngs , ngs+nng(ig)-1
- if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac
- y = nolevg(ing)
- sumx = sumx + x
- sumy = sumy + y
- sumxy = sumxy + x*y
- sumxx = sumxx + x*x
- sumyy = sumyy + y*y
- x = x+emgfac
-118 continue
- delta = nng(ig)*sumxx-sumx*sumx
- em = (nng(ig)*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*gslfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/gslfac*sumx)/nng(ig)
- nolev1 = nint(beta)
-c
-c Back up
-c
- notexq = sq//'settiny'//sq//'off{'
- if (normsp) then
- write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig)
- call addstr(notexq(1:18)//'pt}',21,soutq,lsout)
- finalshift = ptgr(ig)
- else
- aftshft = wheadpt*1.33
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5
- write(notexq(14:17),'(f4.1)')aftshft
- call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout)
- end if
-c
-c Start the beam
-c
- notexq = sq//'ib'
- do 119 ing = 2 , mg
- notexq = notexq(1:ing+1)//'b'
-119 continue
- if (upg(ig)) then
- notexq = notexq(1:mg+2)//'u'
- else
- notexq = notexq(1:mg+2)//'l'
- end if
- notexq = notexq(1:mg+3)//'0'
-c
-c Get starting note for beam
-c
- call notefq(noteq,lnoten,nolev1,ncm)
- call addstr(notexq(1:mg+4)//noteq(1:lnoten),
- * mg+4+lnoten,soutq,lsout)
-c
-c Put in the slope
-c
- if (islope .ge. 0) then
- call addstr(chax(48+islope),1,soutq,lsout)
- else
- call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout)
- end if
-c
-c Start a slur on multiple fore-grace
-c
- if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Need a tweak for postscript slur
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print 11-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten,
- * soutq,lsout)
- else if (23-ndxslur .lt. 2) then
- call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
-c
-c Put in tweak for postscript slur
-c
- if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout)
- end if
-c
-c Put in first note. Call notefq again in case octave changed
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (naccg(ngs) .eq. 0) then
- notexq = sq//'zqb0'//noteq(1:lnoten)
- lnote = 5+lnoten
- else
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten)
- lnote = 4+lacc+lnoten
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten)
- lnote = lnote+5+lnoten
- end if
- call addstr(notexq,lnote,soutq,lsout)
- do 127 ing = ngs+1 , ngs+nng(ig)-1
-c
-c Skip
-c
- ptoff = wheadpt1*emgfac
- if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac
- if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
- notexq = sq//'off{'
- write(notexq(6:8),'(f3.1)')ptoff
- if (normsp) finalshift = finalshift-ptoff
- call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
- if (ing .eq. ngs+nng(ig)-1) then
-c
-c Terminate beam if needed
-c
- if (upg(ig)) then
- call addstr(sq//'tbu0',5,soutq,lsout)
- else
- call addstr(sq//'tbl0',5,soutq,lsout)
- end if
-c
-c Terminate after slur if needed
-c
- if ((isgaft.or.iswaft) .and. slurg(ig)) then
-c if (iswaft) ndxslur = igetbits(ipl,4,23)
- if (iswaft) ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-c Print 11-ndxslur
-cc Print 23-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- end if
-c
-c Stop slur terminator after exit from this subroutine
-c
- listslur = ibclr(listslur,ndxslur)
- slurg(ig) = .false.
- end if
- end if
-c
-c Accidental if needed
-c
- if (naccg(ing).gt.0) then
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ing),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)
- * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
-c
-c Put in the (beamed) grace note
-c
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten,
- * soutq,lsout)
-127 continue
-c
-c Terminate the grace
-c
-c notexq = sq//'normalnotesize'//sq//'off{'
-c lnote = 20
-c notexq = '}'//sq//'off{'
-c lnote = 6
- notexq = sq//'off{'
- lnote = 5
- ptoff = wheadpt*emgfac
- if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17))
- * ptoff = ptoff+wheadpt*accfac
- if (isgaft .and. .not.iswaft) then
- notexq = notexq(1:5)//'-'
- lnote = 6
- ptoff = aftshft
- end if
- if (normsp) ptoff = finalshift
- if (ptoff .lt. 9.95) then
- write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
- lnote = lnote+3
- else if (ptoff .lt. 99.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff
- lnote = lnote+5
- end if
- call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
- if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
- call addstr(sq//'resetsize',10,soutq,lsout)
- end if
- return
- end
- subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip,
- * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur,
- * ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note.
-c 12 May 2002 Create this subroutine to isolate postscript slurs/ties.
-c Always set \Nosluradjust\Notieadjust
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,
- * settie,fontslur,pstie,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term.
-c 18 int(ndxslur/16), ditto. So this allows ndxslur>15.
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-c
-c Bits in isdat4 Only used for linebreak slurs
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-13.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
- * kv .eq. igetbits(isdata,1,12)+1) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- pstie = btest(isdat2(isdat),3) .or. idcode.eq.1
- if (btest(isdata,11)) then
-c
-c Turnon
-c
-c if (nolevs.eq.0 .or. nolevs.gt.60) then
-cc
-cc Note was a rest, cannot start slur on rest.
-cc
-c print*
-c call printl('Cannot start slur on a rest')
-c call stop1()
-c nolevs = ncm+5
-c end if
-c
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
-c
-c Set level for slur starting on rest
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
- if (slurudq .eq. 'u') then
- nolevs = ncm+2
- else
- nolevs = ncm-2
- end if
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from 12 down
-c
- ndxslur = log2(16777215-listslur)
-c write(*,'()')
-c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c write(*,'(10x,B24)')listslur
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff+8
- else
- ihoff = ihoff+2
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- notexq = chax(92)
- lnote = 1
-c
-c Check for local adjustment default changes
-c
- if (btest(isdat2(isdat),26)) then
- notexq = chax(92)//'sluradjust'//chax(92)
- lnote = 12
- else if (btest(isdat2(isdat),27)) then
- notexq = chax(92)//'nosluradjust'//chax(92)
- lnote = 14
- else if (btest(isdat2(isdat),28)) then
- notexq = chax(92)//'tieadjust'//chax(92)
- lnote = 11
- else if (btest(isdat2(isdat),29)) then
- notexq = chax(92)//'notieadjust'//chax(92)
- lnote = 13
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = notexq(1:lnote)//'islur'//slurudq
- lnote = lnote+6
- else
- notexq = notexq(1:lnote)//'is'//slurudq
- lnote = lnote+3
- end if
-c
-c Prepend postscript tie switch
-c
- if (pstie) then
- notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote)
- lnote = lnote+10
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
-c noteq = notexq
-c notexq = chax(92)//'dotted'//noteq
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
-c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- islhgt = nolevs+iupdn+ivoff
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Store height and staff mid level for use with LineBreakTies
-c
- call setbits(isdat3(isdat),8,14,islhgt)
- call setbits(isdat3(isdat),8,22,ncm)
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
-c levson(midchan(iv,kv)) = nolev
- levson(midchan(iv,kv)) = nolevs
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
- * kv.eq.igetbits(isdat1(j),1,12)+1) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
-c
-c Bugfix 070901 for slur ending on rest in 2-voice staff
-c
-c if (nolevs.eq.0 .or. nolevs.gt.60) then
- if (nolevs.le.2 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then
-c
-c Deal with \curve or \midslur. isdat is ending, j is start.
-c
- if (btest(isdat3(isdat),0)) then
- imid = igetbits(isdat3(isdat),6,2)-32
- else
- imid = igetbits(isdat3(j),6,2)-32
- end if
-c
-c Postscript slurs, and \midslur adjustment is needed. Invoke macro
-c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 2-3 default
-c 4 h
-c 5 H
-c 6+ HH
-c
- call addstr(chax(92)//'psforts'//
- * chax(48+min(abs(imid),6)),9,soutq,lsout)
- end if
-c
-c Shift slur ending for stem on any note?
-c
- if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff-8
- else
- ihoff = ihoff-3
- end if
- end if
- if (iscrd) then
-c
-c Shift termination for shifted notehead?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c
-c Switch to postscript tie
-c
- if (pstie) then
- notexq = chax(92)//'tieforts'//notexq(1:lnote)
- lnote = lnote+9
- end if
-c
-c Print 13-ndxslur
-c 5/25/08 Allow 14 slurs
-c
- if (23-ndxslur .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- end if
- ivoff = ivoff+ivoffinc
- end if
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
- if (idcode .eq. is2n1) is1n1=0
- end if
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihoff .ne. 0) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Clear the bit from list of slurs in use
-c
- listslur = ibclr(listslur,ndxslur)
-c
-c Zero out the entire strings for start and stop
-c
- isdata = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(j) = 0
- isdat4(j) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
- icm = midchan(iv,kv)
- if (slmon(icm)) then
- if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then
-c
-c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
-c
- levsoff(icm) = nolevs
- settie = .true.
- else
- levsoff(icm) = 0
- levson(icm) = 0
- slmon(icm) = .false.
- end if
- end if
- end if
- end if
- isdat1(isdat) = isdata
- end if
-1 continue
-c
-c Clear and collapse the slur data list
-c
- numdrop = 0
- do 2 isdat = 1 , nsdat
- if (isdat1(isdat) .eq. 0) then
- numdrop = numdrop+1
- else if (numdrop .gt. 0) then
- isdat1(isdat-numdrop) = isdat1(isdat)
- isdat2(isdat-numdrop) = isdat2(isdat)
- isdat3(isdat-numdrop) = isdat3(isdat)
- isdat4(isdat-numdrop) = isdat4(isdat)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv,
- * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note. (5/26/02) for non-ps slurs only
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove,
- * settie,fontslur,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-23.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (btest(islur,1)) then
-c
-c 't'-slur (idcode=1) somewhere on this note. Find it, check height against
-c 's'-slur (idcode=32)
-c
- sfound = .false.
- tfound = .false.
- tmove = .false.
- do 5 isdat = 1 , nsdat
- if (iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * ip .eq. igetbits(isdat1(isdat),8,3) .and.
- * kv .eq. igetbits(isdat1(isdat),1,12)+1) then
- if (.not.tfound) then
- tfound = igetbits(isdat1(isdat),7,19).eq.1
- if (tfound) then
- nolevt = igetbits(isdat2(isdat),7,19)
- isdatt = isdat
- if (sfound) go to 6
- end if
- end if
- if (.not.sfound) then
- sfound = igetbits(isdat1(isdat),7,19).eq.32
- if (sfound) then
- nolevs = igetbits(isdat2(isdat),7,19)
- isdats = isdat
- if (tfound) go to 6
- end if
- end if
- end if
-5 continue
-c
-c Will come thru here if there is a t with no s, so comment out the following
-c print*,'Did not find s+t-slurs in doslur'
-c
-6 continue
- if (sfound .and. tfound)
- * tmove = nolevs.eq.nolevt .and.
-c
-c Check if 2 starts or two stops
-c
- * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or.
- * (.not.btest(isdat1(isdats),11).and.
- * .not.btest(isdat1(isdatt),11)) )
-c
-c This is a flag for later changing slur level, after we know slur dir'n.
-c
- end if
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
- * kv .eq. igetbits(isdata,1,12)+1) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- if (btest(isdata,11)) then
-c
-c Turnon,
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Note was a rest, cannot start slur on rest.
-c
- print*
- call printl('Cannot start slur on a rest')
- call stop1()
- end if
-c
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (idcode.eq.1 .and. tmove) then
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twenty-fifth slur, one too many!'
- write(15,'(/,a)')
- * 'You2 defined the twenty-fifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from ? down
-c
- ndxslur = log2(16777215-listslur)
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.)
- * ihoff = ihoff+8
- if (btest(isdat2(isdat),3)) then
-c
-c Tie spacing, (slur start)
-c
- if (slurudq.eq.'d') then
- ivoff = ivoff+1
- ihoff = ihoff+8
- else if (slurudq.eq.'u') then
- ivoff = ivoff-1
- if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8
-c
-c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u')
-c
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = chax(92)//'islur'//slurudq
- lnote = 7
- else
- notexq = chax(92)//'is'//slurudq
- lnote = 4
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
- noteq = notexq
- notexq = chax(92)//'dotted'//noteq
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. idcode.eq.32) then
- levson(midchan(iv,kv)) = nolevs
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
- * kv.eq.igetbits(isdat1(j),1,12)+1) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Deal with \curve or \midslur
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Remember, only dealing with non-ps slurs
-c
-c Who knows where the following line came from. Removed it 6/30/02 to
-c restore behavior of non-ps slurs to old way
-c if (slurudq .eq. 'd') imid = -imid
-c 3/8/03 added the following
-c
- if (slurudq .eq. 'd') imid = -abs(imid)
-c
- if (btest(isdat3(isdat),1)) then
- notexq = chax(92)//'curve'
- lnote = 6
- else
- notexq = chax(92)//'midslur'
- lnote = 8
- end if
- if (imid.lt.0 .or. imid.gt.9) then
-c
-c Need brackets
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (imid .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')imid
- lnote = lnote+3
- else if (imid.lt.0 .or. imid.gt.9) then
- write(notexq(lnote+1:lnote+2),'(i2)')imid
- lnote = lnote+2
- else
- write(notexq(lnote+1:lnote+1),'(i1)')imid
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
-c
-c 1=<imid=<9, no brackets
-c
- notexq = notexq(1:lnote)//char(48+imid)
- lnote = lnote+1
- end if
- if (btest(isdat3(isdat),1)) then
-c
-c \curve; 3 args
-c
- notexq = notexq(1:lnote)
- * //char(48+igetbits(isdat3(isdat),3,8))
- notexq = notexq(1:lnote+1)
- * //char(48+igetbits(isdat3(isdat),3,11))
- lnote = lnote+2
- end if
- call addstr(notexq,lnote,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.)
- * ihoff = ihoff-8
- if (btest(isdat2(isdat),3)) then
-c
-c Shift ending for tie spacing
-c
- if (slurudq .eq. 'u') then
- ihoff = ihoff-8
- ivoff = ivoff-1
- else if (slurudq .eq. 'd') then
- ivoff = ivoff+1
- if (stemup.or. tno.gt.63.) ihoff = ihoff-8
- 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 Print 23-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
- if (idcode.eq.1 .and. tmove) then
-c
-c t-slur height adjustment
-c
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- 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
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(isdat) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. idcode.eq.32) 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)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine dotmov(updot,rtdot,soutq,lsout,iddot)
-c
-c iddot = 0 for single dot, 1 for double
-c
- character*80 soutq,notexq
- character*1 sq,chax
- sq = chax(92)
- lfmtup = lfmt1(updot)
- lfmtrt = lfmt1(rtdot)
- write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt)
- * //'.1,a15)')
- * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq//
- * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq
- * //'makeatother'
-c
-c Example of string just created:
-c \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\
-c
- lnote = 54+lfmtup+lfmtrt
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- return
- end
- subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
- 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*1 chax
- character*8 noteq
- character*79 notexq
- logical tronly,btest
- do 1 itr = 1 , ntrill
- if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
-1 continue
- print*,'Problem in dotrill. Call Dr. Don'
- stop
-2 continue
- tronly = xnsktr(itr) .lt. 0.01
- if (tronly) then
- notexq = chax(92)//'zcharnote'
- lnote = 10
- else if (btest(iornq,7)) then
- notexq = chax(92)//'Trille'
- lnote = 7
- else
- notexq = chax(92)//'trille'
- lnote = 7
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
-c
-c Write trill duration to nearest tenth of a noteskip
-c
- if (tronly) then
- notexq = notexq(1:lnote)//chax(92)//'it tr}'
- lnote = lnote+7
- return
- end if
- if (xnsktr(itr) .lt. .95) then
- nfmt = 2
- else if (xnsktr(itr) .lt. 9.95) then
- nfmt = 3
- else
- nfmt = 4
- end if
- write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)')
- * xnsktr(itr)
- lnote = lnote+nfmt
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- return
- end
- subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
- * soutq,lsout,fontslur)
-c
-c Only called to end slur started in dograce.
-c
- logical shift,stemup,upslur,fontslur
- character*80 soutq
- character*79 notexq
- character*8 noteq
- character*1 chax
- shift = .not.stemup .and. .not.upslur
- if (.not.shift) then
-c
-c No shift needed
-c
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c if (ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(48+ndxslur)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
-c lnote = lnote+4
-c end if
-c
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-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
- call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (shift) then
- if (fontslur) then
- notexq = notexq(1:lnote)//'{-.6}'
- else
- notexq = notexq(1:lnote)//'{-.8}'
- end if
- lnote = lnote+5
- end if
- call addstr(notexq,lnote,soutq,lsout)
- return
- end
- subroutine errmsg(lineq,iccount,ibarno,msgq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*128 lineq
- character*78 outq
- character*(*) msgq
- character*1 chax
- common /truelinecount/ linewcom(20000)
- if (iccount .le. 78) then
- outq = lineq(1:78)
- iposn = iccount
- else
- outq = '... '//lineq(55:128)
- iposn = iccount-50
- end if
- print*
- ibarnop = ibarno
- if (linesinpmxmod.eq.0 .or.
- * nline .gt. line1pmxmod+linesinpmxmod) then
-c
-c Error is in main .pmx file
-c
-c nlinep = nline-linesinpmxmod
-c Correct for comments not copied into buffer
- nlinep = linewcom(nline)-linesinpmxmod
- else
-c
-c Error is in include file
-c
- ibarnop = 0
- nlinep = nline-line1pmxmod+1
- call printl(
- * 'ERROR in include file named above, description given below')
- end if
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') nlinep
- close(19)
- ndigbn = max(1,int(log10(ibarnop+.1)+1))
- ndignl = int(log10(nlinep+.1)+1)
- lenmsg = index(msgq,'!')-1
-c
-c Split off msgq(..) since UNIX compilers don't allow concat substring!!!
-c
- write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(*,'(1x,a)')msgq(1:lenmsg)
- write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(15,'(a)')msgq(1:lenmsg)
- i10 = iposn/10
- i1 = iposn-10*i10
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- print*,outq(1:78)
- write(15,'(a)')' '//outq(1:78)
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- return
- end
- subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
-c
-c Get elemskips to previous note. Called only for graces, no xtups involved.
-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)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- real*4 tstart(80),space(80)
- common /comtol/ tol
- itnd = nint(to(in))
- if (ip.eq.1 .or. itnd.eq.itrpt) then
-c
-c Start of bar or after rpt.
-c
- esk = fbar
- return
- else
- esk = 0.
- itprev = itnd-nodur(ivx,ip-1)
- do 1 iib = ib , 1 , -1
- if (tstart(iib) .lt. itprev+tol) then
-c
-c This is the block
-c
- nnsk = nint(float((itnd-itprev))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- return
- else
- nnsk = nint((itnd-tstart(iib))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- itnd = nint(tstart(iib))
- end if
-1 continue
- end if
- print*,'Problem in eskb4. Send files to Dr. Don'
- stop
- end
- function f1eon(time)
- f1eon = sqrt(time/2)
- return
- end
- function feon(time)
- common /comeon/ eonk,ewmxk
- feon = sqrt(time/2)**(1.-eonk)*ewmxk
- return
- end
- subroutine findbeam(ibmrep,numbms,mapfb)
-c
-c Called once per voice per bar, after setting forced beams.
-c
- parameter (nm=24)
- dimension mask(49,3),nummask(3),eqonly(49,3)
-c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16),
-c * itr(48),nodue(48)
-c logical short(48),eqonly
- integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(16),
- * itr(248),nodue(248)
- logical short(248),eqonly
- 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)
- common /combeam/ ibmtyp
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,btest
- data nip1,nip2 /496*0/
- data nummask / 29 , 49 , 12 /
- data mask
- * / 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, 20*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,
- * 37*0 /
- data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
- ip = 0
- nreal = 0
- itnow = 0
-1 continue
- ip = ip+1
- if (ip .gt. nn(ivx)) go to 9
-11 if (nodur(ivx,ip).eq.0) then
-c
-c Ignore all xtup notes except the last, the one with nodur > 0 .
-c Xtups are irrelevant here since they are already all in forced beams.
-c Will update itnow by nodur at the END of this loop
-c
- ip = ip+1
- go to 11
- end if
- nreal = nreal+1
- nodue(nreal) = nodur(ivx,ip)
- short(nreal) = nodue(nreal).lt.16 .and.
- * .not.btest(irest(ivx,ip),0)
-c
-c Rule out notes that have 'alone'-flag set
-c
- * .and..not.btest(islur(ivx,ip),18)
- ipr(nreal) = ip
- itr(nreal) = itnow
- if (nodue(nreal) .eq. 1) then
-c
-c 64th gap
-c
- if (mod(itnow,2) .eq. 0) then
-c
-c Start of 32nd gap, lump with following note
-c
- ip = ip+1
- nodue(nreal) = 1+nodur(ivx,ip)
- itnow = itnow+nodue(nreal)
- else
-c
-c End of 32nd gap, lump with preceeding note
-c
- nreal = nreal-1
- nodue(nreal) = 1+nodue(nreal)
- itnow = itnow+1
- end if
- else
- itnow = itnow+nodur(ivx,ip)
- end if
- go to 1
-9 continue
- ir1 = 1
- itseg = lenbar/ibmrep
- do 13 irep = 1 , ibmrep
-c
-c Set bitmaps for all shorts neighbored by a short. Each bit represents a
-c span of 32nd note. maps, mapm, mape record start, full duration, and end
-c of consecutive span of beamable (<1/4) notes.
-c
- maps = 0
- mapm = 0
- mape = 0
- itend = itseg*irep
- itoff = itend-itseg
- do 2 ir = ir1 , nreal
- it2 = itr(ir)+nodue(ir)-2
- if (it2 .ge. itend) then
- ir1 = ir
- go to 14
- end if
-c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal
- if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or.
- * (ir.lt.nreal.and.short(ir+1)))) then
- ib1 = (itr(ir)-itoff)/2
- ib2 = (it2-itoff)/2
- if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or.
- * min(ib1,ib2).lt.0) return
-c
-c Must have an odd number obe beats in a long bar. Auto-beam won't work
-c
- nip1(ib1) = ipr(ir)
- nip2(ib2) = ipr(ir)
-c
-c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip
-c
- maps = ibset(maps,ib1)
- mape = ibset(mape,ib2)
- do 3 ib = ib1 , ib2
- mapm = ibset(mapm,ib)
-3 continue
- end if
-2 continue
-14 continue
- if (mapm .eq. 0) go to 13
-c
-c Zero out bits from forced beams
-c
- maps = iand(maps,not(mapfb(irep)))
- mapm = iand(mapm,not(mapfb(irep)))
- mape = iand(mape,not(mapfb(irep)))
-c
-c Compare map with template.
-c
- do 4 it = 1 , nummask(ibmtyp)
- masknow = mask(it,ibmtyp)
- if (iand(masknow,mapm) .eq. masknow) then
-c
-c Find least significant bit in the mask to check start time
-c
- mtemp = masknow
- maskm = masknow
- do 5 is1 = 0 , 47
- if (iand(1,mtemp) .eq. 1) go to 6
- mtemp = ishft(mtemp,-1)
-5 continue
-6 continue
- if (iand(ishft(1,is1),maps) .eq. 0) go to 4
-c
-c is1 is the bit where the beam starts. Continue shifting to
-c find most significant bit in the mask to check ending time
-c
- do 7 is2 = is1 , 47
- mtemp = ishft(mtemp,-1)
- if (iand(1,not(mtemp)) .eq. 1) go to 8
-7 continue
-8 continue
-c
-c is2 is now the bit on which the beam ends.
-c
- if (iand(ishft(1,is2),mape) .eq. 0) go to 4
-c
-c Did we pick out a single note from the middle of a longer sequence?
-c
- if (nip1(is1) .eq. nip2(is2)) go to 4
-c
-c We almost have a beam. Check equality of notes if needed.
-c
- if (eqonly(it,ibmtyp)) then
- do 10 ip = nip1(is1) , nip2(is2)
- if (nodur(ivx,ip) .ne. 8) then
-c
-c There is a non-1/8th note in this beam. Exit if not 2 quarters
-c
- if (is2-is1 .ne. 15) go to 4
-c
-c Beam is 2 quarters long. Check if can split in half.
-c
- ithalf = 0
- do 20 iip = nip1(is1) , nip2(is2)
- ithalf = ithalf+nodur(ivx,iip)
- if (ithalf .gt. 16) go to 4
- if (ithalf .eq. 16) go to 21
-20 continue
- print*,'Problem in findbeam, please call Dr. Don'
- go to 4
-21 continue
-c
-c Otherwise, split in half by keeping only the first half. Other half will
-c be picked up later, assuming masks are listed longest first.
-c
- is2 = is1+7
-c
-c Reset maskm (since only used part of mask), used later to zero out
-c bits that contain beams
-c
- maskm = 0
- do 15 is = is1 , is2
- maskm = ibset(maskm,is)
-15 continue
- go to 16
- end if
-10 continue
- end if
-16 continue
-c
-c This is a beam. If last "effective" ends on odd 64th, add 1 more
-c
-c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2))))
-c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then
- if (abs(amod(to(ipl2(ivx,nip2(is2)))
- * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then
- nip2(is2) = nip2(is2)+1
- end if
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
- call logbeam(numnew,nip1(is1),nip2(is2))
-c
-c Zero out the appropriate bits so these notes don't get used again
-c
- mapm = iand(mapm,not(maskm))
- if (mapm.eq.0) go to 13
- maps = iand(maps,not(maskm))
- mape = iand(mape,not(maskm))
- end if
-4 continue
-13 continue
- return
- end
- subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0)
- parameter (nkb=3999,maxblks=4000)
-c
-c Compute an exponent eonk for use in the "flattened" formula for elemskips
-c vs time. We must solve the eqution f = 0. Initial quess is eonk0.
-c
- logical gotclef
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /comtol/ tol
- common /comeon/ eonk,ewmxk
- eonk = eonk0
- niter = 0
-1 continue
- ewmxk = f1eon(dtmax)**eonk
- niter = niter+1
- esum = 0.
- desum = 0.
- do 2 iptr = nptr1 , nptr2
- targ = durb(iptr)/sqzb(iptr)
- esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ)
- detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ)
- desum = desum+nnpd(iptr)*sqzb(iptr)*detarg
-2 continue
- f = wovera*feon(dtmin)-xelsk-esum
- fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin)
- * -desum
- if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then
- call printl(
- * 'Error in findeonk. Please send source to Dr. Don')
- eonk = 0.
- ewmxk = 1.
- return
- end if
- dsoln = -f/fp
- if (abs(dsoln) .lt. .1*tol) return
-c
-c Not converged yet, try again
-c
- eonk = eonk+dsoln
- go to 1
- end
- function fnote(nodur,ivx,ip,nacc)
-c
-c This return the real duration of a note
-c
- parameter (nm=24)
- integer*4 nodur(nm,200),nacc(nm,200)
- logical btest
- ipback = ip
- if (nodur(ivx,ip) .gt. 0) then
- if (ip .gt. 1) then
-c
-c Check if this is last note of xtup
-c
- if (nodur(ivx,ip-1).eq.0) then
- ipback = ip-1
- go to 2
- end if
- end if
- fnote = nodur(ivx,ip)
- return
- end if
-2 continue
-c
-c Count back to prior non zero note. Start at ip to avoid neg index if ip=1.
-c Count how many doubled xtups notes there are from ip-1 to first note.
-c
- ndoub = 0
- do 1 ip1m1 = ipback , 1 , -1
- if (nodur(ivx,ip1m1) .gt. 0) go to 4
- if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1
-1 continue
-4 continue
-c
-c count forward to next non-0 nodur. Start at ip in case last note of xtup.
-c
- do 3 iip = ip , 200
-c
-c Count doubled xtup notes from ip to end.
-c
- if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1
- if (nodur(ivx,iip) .gt. 0) then
-c fnote = nodur(ivx,iip)/float(iip-ip1m1)
- fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub)
- if (btest(nacc(ivx,ip),18)) then
- fnote = 2*fnote
- else if (btest(nacc(ivx,ip),27)) then
- fnote = 1.5*fnote
- else if (ip .gt. 1) then
- if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote
- end if
- return
- end if
-3 continue
- print*,' '
- call printl
- * ('Probable misplaced barline or incorrect meter, stopping')
-c call printl('Program error in fnote, send source to Dr. Don')
- call stop1()
- end
- subroutine g1etchar(lineq,iccount,charq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,issegno,isheadr,isvolt,fbon
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- character*1 charq
- character*128 lineq,lnholdq
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not.endmac) then
- iccount = 0
- if (.not.mplay) nline = nline+1
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
- end
- subroutine g1etnote(loop,ifig,optimize,fulltrans)
- parameter (nm=24,nkb=3999,mv=24576,maxblks=4000)
- character*1 chax
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend,
- * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt,
- * stickyS
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- logical mrecord,mplay,endmac,shifton,gotclef,optimize
- character*128 lineq,lnholdq
- character*1 charq,dotq,dumq,durq,charlq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical novshrinktop,upslur,fontslur,ztrans,
- * WrotePsslurDefaults,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- character*51 literq(3)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- common /comsize/ isize(nm)
- data literq
- * /'Literal TeX string cannot start with 4 backslashes!',
- * 'TeX string must have <129 char, end with backslash!',
- * 'Type 2 or 3 TeX string can only start in column 1!'/
- cdot = .false.
-1 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') charlq = charq
- if (lastchar) then
- if (index('/%',charlq) .eq. 0) then
- print*
- print*,'WARNING:'
- print*,'Last non-blank character is "',charlq,'", not "/,%"'
- print*,'ASCII code:',ichar(charlq)
- write(15,'(/a)')'Last non-blank character is "'//charlq//
- * '", not "/,%"'
- write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq)
-c
-c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1.
-c
- ilbuf = ilbuf-1
- lbuf(ilbuf) = lbuf(ilbuf)+2
- bufq = bufq(1:ipbuf)//' /'
- write(15,*)'appending <blank>/'
- print*,'appending <blank>/'
- lineq = lineq(1:iccount)//' /'
- lastchar = .false.
- go to 1
- end if
- return
- end if
- if (charq .eq. ' ') then
- go to 1
- else if (charq.eq.'%' .and. iccount.eq.1) then
- iccount = 128
- go to 1
-c
-c Replacement 1/22/12 since gfortran 4.7 with -O was choking here!
-c
-c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- else if (index('abcdefg',charq).gt.0 .or.
- * charq.eq.'r') then
-c
-c This is a note/rest. gotclef is only used for checking for clef before "/"
-c
- if (cdot) go to 28
- if (gotclef) gotclef=.false.
- idotform = 0
- numnum = 0
- plusmin = .false.
-28 nnl(ivx) = nnl(ivx)+1
- if (nnl(ivx) .gt. 200) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>200 notes in line of music. Use smaller blocks!')
- call stop1()
- end if
- dotq = 'x'
-c
-c Check if this is 'r ' and previous note was full-bar-pause
-c
- fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and.
- * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar
-2 call g1etchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- if (charq .eq. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one digit allowed after rest symbol "r"!')
- call stop1()
- end if
- numnum = 2
- if (plusmin) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>2 digits in note symbol!')
- call stop1()
- end if
- else if (durq.eq.'d') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
- iddot = 1
- iccount = iccount+1
-c
-c Since we flow out, double dots won't work with other dot options
-c
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, provided a number follows.
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
-c
-c Backup, exit the loop normally
-c
- iccount = iccount-2
- go to 2
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after 2nd +/- (shift dot)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (index('<>',durq) .gt. 0) then
-c
-c Accidental shift
-c
-c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
-c * 'Expected "f", "s", or "n" before "<" or ">"!')
- * 'Expected "f", "s", "n" or "A" before "<" or ">"!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '<') ipm=-1
- call g1etchar(lineq,iccount,durq)
- if (index('123456789.0',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after </> (accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horizontal accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else if (index('+-',durq) .gt. 0) then
- if (charq .ne. 'r') then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then
- ipm = 1
- if (durq .eq. '-') ipm=-1
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .gt.0) then
-c
-c This may be start of accidental shift, but may be octave jump; then duration
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .gt. 0) then
-c
-c This is an accid shift since there's a 2nd consecutive signed number.
-c Check size of 1st number.
-c
- if (fnum .gt. 30.5) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Vertical accidental shift must be less than 31!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '-') ipm = -1
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected 2nd number of accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horiz. accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else
-c
-c Not accid shift, reset, then flow out
-c
- iccount = icsav
- end if
- end if
- end if
- plusmin = .true.
- if (numnum .eq. 2) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
-c
-c It's a rest containing +|- . Must refer to a vertical shift. Read past.
-c
- else
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,dum)
- iccount = iccount-1
- go to 2
- end if
-c else if (index('ulare',durq) .gt. 0) then
- else if (index('ularec',durq) .gt. 0) then
- go to 2
- else if (durq .eq. 'S') then
-c
-c Stemlength change
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789:',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a number or colon here!')
- call stop1()
- end if
- if (durq .eq. ':') then
- if (.not.stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned off sticky stemshrinks without turning on!')
- call stop1()
- end if
- stickyS = .false.
- go to 2
- end if
- call readnum(lineq,iccount,durq,dum)
- if (dum.lt..5 .or. dum.gt.4.) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Stemlength shortening must be from .5 to 4!')
- call stop1()
- end if
- if (durq .ne. ':') then
- iccount = iccount-1
- else
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on sticky stemshrinks when already on!')
- call stop1()
- end if
- stickyS = .true.
- end if
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 2
- else if (durq .eq. 'p') then
- fulbrp = charq.eq.'r'
- if (.not. fulbrp) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'The option "p" only works with "r" (rest)!')
- call stop1()
- end if
- go to 2
- else if (durq .eq. 'b') then
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "b"; I expected "rb"!')
- call stop1()
- else if (numnum .eq. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "r" & "b" with two numbers!')
- end if
- go to 2
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Will set all durations to 0 except last one.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'First char after "x" in xtuplet must be "1"-"9"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (fnum .gt. 99) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Xtuplet cannot have more than 99 notes!')
- call stop1()
- else if (index(' DFnd',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only legal characters here are " ","D","F","n"!')
- call stop1()
- end if
-c
-c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n.
-c
- if (index('DF',durq) .gt. 0) then
-c
-c Double xtup note to make an un= xtup. Here, number already set, but may also
-c have used this before number was set.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = 1
- call g1etchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call g1etchar(lineq,iccount,durq)
- end if
- if (durq .eq. 'n') then
-c
-c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'.
-c
- numshft = 0
-30 call g1etchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
- go to 30
- else if (index('+-',durq) .gt. 0) then
- numshft = numshft+1
- if (numshft .eq. 3) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only 2 shifts are allowed after "n" in xtup!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit or "."!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
- if ((numshft.eq.1 .and. snum.gt.15.1) .or.
- * (numshft.eq.2 .and. snum.gt.1.51)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Shift number after "n" in xtup is out of range!')
- call stop1()
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope alteration for bracket
-c
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'For slope adjustment, this character must be "+" or "-"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
- if (nint(snum) .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slope adjustment cannot exceed 15!')
- call stop1()
- end if
- go to 30
- else if (index('123456789',durq) .gt. 0) then
-c
-c Unsigned integer => alternate printed number
-c
- call readnum(lineq,iccount,durq,snum)
- if (snum .gt. 15.1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Alternate xtup number after "n" must be <16!')
- call stop1()
- end if
- iccount = iccount-1
- go to 30
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "n" in xtup!')
- call stop1()
- end if
- end if
- ntup = nint(fnum)
- do 6 itup = 2 , ntup
- nodur(ivx,nnl(ivx)) = 0
- nnl(ivx) = nnl(ivx)+1
-110 call g1etchar(lineq,iccount,durq)
- if (durq.eq.' ') then
- go to 110
- else if (durq .eq. 'o') then
-c
-c Ornament in xtup. "o" symbol must come AFTER the affected note
-c
- call g1etchar(lineq,iccount,dumq)
- if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then
- if (index('fg',dumq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Fermata or segno not allowed in xtuplet!')
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- end if
- call stop1()
- end if
- if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-29 call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') go to 29
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,
- * ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
- go to 110
- else if (index('st(){}',durq) .gt. 0) then
-c
-c Slur in xtup
-c
- iposn = 0
- numint = 0
-15 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (index('udlbfnht',dumq) .gt. 0) then
- if (dumq.eq.'t' .and. durq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- go to 15
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum).gt.6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in the range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 40 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,
- * ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-40 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 15
-
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 15
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H')
- * iccount=iccount+1
- go to 15
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- go to 15
- else if (dumq .ne. ' ') then
- ic = ichar(dumq)
- if ((ic.ge.48.and.ic.le.57) .or.
- * (ic.ge.65.and.ic.le.90)) then
- if (iposn .eq. 1) then
- if (durq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- end if
- go to 15
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be 2nd character in slur symbol!')
- call stop1()
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- end if
- go to 110
- else if (index('0123456789#-nx_',durq) .gt. 0) then
-c
-c We have a figure. Only allow on 1st note of xtup
-c
- if (itup .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Figure in xtup only allowed on 1st note!')
- call stop1()
- else if (durq.eq.'x') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'No floating figures in xtuplets!')
- call stop1()
- end if
- if (usefig .and. ivx.eq.1) ifig = 1
-26 call g1etchar(lineq,iccount,durq)
- if (index('0123456789#-n_.:',durq) .gt. 0) then
- go to 26
- else if (durq .eq. 's') then
- isligfont = .true.
- go to 26
- else if (durq .eq. '+') then
-c
-c vertical offset, must be integer then blank
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .ne. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 26
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure in xtuplet!')
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'G') then
- ngr = 1
-79 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 79
- else if (index('AWulxs',charq) .gt. 0) then
- go to 79
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 79
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 79
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 71 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-75 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 75
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-78 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 78
- else if (index('+-nfs',charq) .gt. 0) then
- go to 78
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-71 continue
- go to 110
- else if (durq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'M') then
-c
-c Temporary trap until I get around putting this in pmxb
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macros not yet allowed in xtuplets!')
- call stop1()
- else if (durq .eq. 'X') then
- call g1etx(lineq,iccount,.false.,shifton,
- * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt)
- go to 110
- else if (durq .eq. 'z') then
-c
-c Chord note in xtup. Read past for now.
-c
-33 call g1etchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 33
- go to 110
- else if (durq .eq. 'D') then
-c
-c Dynamic mark
-c
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- go to 110
- else if (durq .eq. '%') then
- if (iccount .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Comment must have "%" in column 1!')
- call stop1()
- end if
- iccount = 128
- go to 110
- else if (durq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- go to 110
- end if
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 110
-c+++
- else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'['
- * .and. lineq(iccount+2:iccount+2).eq.' ') then
- iccount = iccount+2
- go to 110
-c+++
- end if
-c
-c End of xtup options. At this point symbol can only be note or rest
-c
- if (index('abcdefgr',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In xtup, this character is not allowed!')
- call stop1()
- else if (durq.eq.'r' .and. itup.eq.ntup) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry, PMX cannot end an xtuplet with a rest!')
- call stop1()
- end if
-7 call g1etchar(lineq,iccount,durq)
- if (index('2345678ulcb',durq) .gt. 0) then
- go to 7
- else if (index('sfn',durq) .gt. 0) then
-c
-c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift.
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 7
- else if (index('+-<>',durq) .gt. 0) then
-c
-c May have either octave jump or shifted accid. on main xtup note
-c
- if (index('+-',durq).gt.0 .and.
- * index('01234567890',lineq(iccount+1:iccount+1)).eq.0)
- * go to 7
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 7
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = ndoub+1
- go to 7
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- go to 7
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal option on xtuplet note!')
- call stop1()
- end if
- if (itup .eq. ntup-ndoub) go to 3
-6 continue
-3 continue
-c
-c 6==End of loop for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c
- if (mod(itsofar(iv),lenbar) .ne. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest must start at beginning of bar!')
- call stop1()
- else if (iv.eq.1.and.ibarmbr.gt.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest only OK at one time per block!')
- call stop1()
- end if
-c
-c For some purposes, pretend its one bar only
-c
- nodur(iv,nnl(iv)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
-c20 call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer after "rm"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mbrest = nint(fnum)
- iccount = iccount-1
-c if (ichar(durq).ge.48.and.ichar(durq).le.57) then
-c mbrest = 10*mbrest+ichar(durq)-48
-c go to 20
-c end if
- if (nv .gt. 1) then
- if (iv .eq. 1) then
- mbrestsav = mbrest
- else
- if (mbrest .ne. mbrestsav) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must enter same multi-bar rest in every voice!')
- call stop1()
- end if
- end if
-c
-c Zero out mbrestsav so can check at end of input block whether
-c all voices have one
-c
- if (iv .eq. nv) mbrestsav=0
- end if
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "rm"!')
- call stop1()
- end if
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. ',') then
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (index('oL',durq) .gt. 0) then
-c
-c Suppress full bar rest, or look left for height
-c
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o","L" options only legal for rest, not note!')
- call stop1()
- end if
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" or "F" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Main note accidental option
-c
- call getchar(lineq,iccount,durq)
- if (index('o+-<>',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o",+","-","<",">" are the only legal options here!')
- call stop1()
- end if
-c
-c Need more stuff here
-c
- if (durq .ne. "o") then
-c
-c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will
-c proceed to number input checking
-c
- iccount = iccount-1
- end if
- go to 2
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character!')
- print*,'ASCII code:',ichar(durq)
- call stop1()
- end if
-c
-c End of block for note options.
-c
-c Set the duration
-c
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
-c
-c Check for double dot
-c
- if (iddot .eq. 1) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- iddot = 0
- end if
- else if (fulbrp) then
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- fulbrp = .false.
- end if
- rest(ivx,nnl(ivx)) = charq.eq.'r'
-c
-c If inside forced beam, check if note is beamable
-c
- if (fbon) then
- if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120
- if (nnl(ivx) .gt. 1) then
- if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unbeamable thing in forced beam!')
- call stop1()
- end if
-120 continue
-c
-c Get number of prior bars for later check on whether note spans bar line
-c
- nbb4 = itsofar(ivx)/lenbar
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (mod(itsofar(ivx),lenbar) .eq. 0) then
- nbars = nbars+1
- if (shifton) barend = .true.
-c
-c Will check barend when 1st note of next bar is entered.
-c
- if (nbars .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have more than 15 bars in an input block!')
- call stop1()
- end if
- nib(ivx,nbars) = nnl(ivx)
- if (firstline .and. lenbar.ne.lenbr1) then
-c
-c Just finished the pickup bar for this voice.
-c
- if (itsofar(ivx) .ne. lenbr0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Pickup bar length disagrees with mtrnum0!')
- call stop1()
- end if
- lenbar = lenbr1
- itsofar(ivx) = 0
- end if
- else if (barend) then
- if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- barend = .false.
- else if (itsofar(ivx)/lenbar .gt. nbb4) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'This note spans a bar line!')
- call stop1()
- end if
- if (idotform.eq.1 .or. idotform.eq.3) then
- call g1etchar(lineq,iccount,charq)
- if (index('abcedfgr',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected note name or "r" here!')
- call stop1()
- end if
- idotform = idotform+1
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
- call g1etchar(lineq,iccount,charq)
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected chord note name here!')
- call stop1()
- end if
-25 call g1etchar(lineq,iccount,durq)
-c if (index('dre12345678',durq) .gt. 0) then
- if (index('dre12345678c',durq) .gt. 0) then
- go to 25
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 25
- else if (durq .eq. 'A') then
- if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n" before "A" in chord note!')
- call stop1()
- end if
- go to 25
- else if (index('<>',durq) .gt. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
-c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n,A" before "<" or ">"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here for accidental shift!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (index('+-',durq) .gt. 0) then
- if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0)
- * go to 25
-c
-c Number or '.' (durq) follows +/- . Get it.
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.' .and. index('1234567890',
- * lineq(iccount+1:iccount+1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"." here must be followed by a digit!')
- call stop1()
- else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Number after +/- must follow "d,s,f,n,A"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .eq. 0) then
- iccount = iccount-1
- go to 25
- end if
-c
-c 2nd +/-
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.') call g1etchar(lineq,iccount,durq)
- if (index('1234567890',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in chord note!')
- call stop1()
- end if
- else if (charq .eq. 'G') then
- ngr = 1
-9 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 9
- else if (index('AWulxs',charq) .gt. 0) then
- go to 9
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 9
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 9
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 19 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-55 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-18 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 18
-c else if (index('nfs',charq) .gt. 0) then
- else if (index('+-nfs',charq) .gt. 0) then
- go to 18
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-19 continue
- else if (charq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. "o" symbol must come AFTER the affected note
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o" must be in same input block, after affected note!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after "o:"!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else if (dumq .eq. 'g') then
- if (issegno) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry, only one "segno" per input block!')
- call stop1()
- else if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'segno can only be in voice 1!')
- call stop1()
- end if
- issegno = .true.
-12 call g1etchar(lineq,iccount,dumq)
- if (dumq.eq.'-' .or.
- * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in segno ornament symbol!')
- call stop1()
- end if
- else if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-22 call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after ":"!')
- call stop1()
- end if
- go to 32
- else if (dumq .ne. ' ') then
- go to 22
- end if
- else if (dumq .eq. 'f') then
- call g1etchar(lineq,iccount,dumq)
- if (index(' d+-:',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "f" in fermata ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') go to 32
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
-32 continue
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- else if (index('st(){}',charq) .gt. 0) then
- numint = 0
- iposn = 0
-8 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (charq.eq.'t' .and. dumq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- if (index('udltb+-fnhHps ',dumq) .eq. 0) then
-c
-c Check for explicit ID code.
-c
- ic = ichar(dumq)
- if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or.
- * ic.gt.90) then
-c
-c Not 0-9 or A-Z, so exit
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- else
-c
-c It is a possible ID code. Right place?
-c
- if (iposn .ne. 1) then
-c
-c Slur ID is not 2nd!
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be second character in slur symbol!')
- call stop1()
- else if (charq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- end if
- end if
-c
-c Slur ID is OK. Note it cannot be "H" at this point..
-c
- go to 8
- else if (dumq .eq. 'H') then
- if (iposn .eq. 1) go to 8
-c
-c "H" is NOT an ID code.
-c
- if (.not.fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- end if
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount=iccount+1
- iposn = iposn+1
- end if
- go to 8
- else if (index('fh',dumq).gt.0 .and. .not.fontslur
- * .and. charq.eq.'t') then
-c
-c 3/9/03 Can't reshape postscript tie.
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- iposn = iposn+2
- go to 8
- end if
- if (index('udltbfnh',dumq) .gt. 0) then
- go to 8
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- if (fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+|-" for slur height only allowed in "s"-slurs!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 41 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-41 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1
- go to 8
- end if
- else if (charq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"!')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- end if
- else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
- * index('#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
- if (itsofar(ivx).eq.0 .and.
- * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then
-c
-c Figure before first note in block
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot put figure before first note in block!')
- call stop1()
- end if
- if (charq.eq.'x') then
- indxb = index(lineq(iccount:128),' ')
- if (indxb .lt. 5) then
- call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have a blank here in floating figure!')
- call stop1()
- end if
- end if
- if (usefig) ifig = 1
-5 call g1etchar(lineq,iccount,charq)
- if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure!')
- call stop1()
- else if (charq .eq. '+') then
-c
-c vertical offset, must be integer, then blank
-c
- call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,charq,fnum)
- if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 5
- else if (charq .eq. 's') then
- isligfont = .true.
- end if
- if (charq .ne. ' ') go to 5
- else if (charq .eq. '[') then
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Started forced beam while another was open!')
- call stop1()
- end if
- fbon = .true.
-17 call g1etchar(lineq,iccount,charq)
- if (index('uljhf:',charq) .gt. 0) then
- go to 17
- else if (index('+-',charq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 17
- else if (charq .eq. 'm') then
-c
-c Forced multiplicity, next char should be 1-4
-c
- call g1etchar(lineq,iccount,charq)
- if (index('1234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!')
- call stop1()
- end if
- go to 17
- else if (charq .ne. ' ') then
- if (index('0123456789',charq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "[", digits must now be preceeded by "+" or "-"!')
- print*,'You will have to edit older sources to meet this rqmt,'
- print*,'but it was needed to allow 2-digit height adjustments.'
- print*,'Sorry for the inconvenience. --The Management'
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after [!')
- end if
- call stop1()
- end if
- else if (charq .eq. ']') then
- if (.not.fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced beam stop with no corresponding start!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,charq)
- if (charq .eq. '-') then
- if (lineq(iccount+1:iccount+2) .ne. '[ ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'Only sequence allowed here is "[ "!')
- call stop1()
- else
- iccount = iccount+2
- end if
- else if (charq .eq. '[') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else
-c
-c Forced beam is really ending
-c
- fbon = .false.
- if (charq .eq. 'j') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"]" must be followed by blank, "j", "-", or "["!')
- call stop1()
- end if
- end if
- else if (charq .eq. 'D') then
-c
-c Dynamic mark
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"D" must not come before any notes have been entered!')
- call stop1()
- end if
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- else if (index('lhw',charq) .gt. 0) then
-c
-c Save position for later check
-c
- icclhw = iccount
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.+- ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "l", "w", or "h"!')
- call stop1()
- end if
- isheadr = isheadr .or. charq .eq. 'h'
- if (index(' +-',durq) .gt. 0) then
-c
-c There is a header (or lower string?)
-c
- if (index('+-',durq) .gt. 0) then
-c
-c User-defined vert offset (\internote).
-c
- if (charq .ne. 'h') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+" or "-" not permitted here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- . Check for digit.
-c Can blow durq since not using fnum for now, but...
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a digit here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- followed by a digit. No need to get the number.
-c
-c call readnum(lineq,iccount,durq,fnum)
- end if
- if (charq .ne. 'w') then
-c
-c Header or lower string.
-c
- if (icclhw .ne. 1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"h" or "l" must be first character in line!')
- call stop1()
- end if
-c
-c Read past the next line, which has the string.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol "w" (width) must be followed by a digit!')
- call stop1()
- end if
- else
-c
-c Height or width change spec. Check if at start of piece.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol must go at top of first input block!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,dimen)
-c
-c Check units. Convert to points
-c
- if (durq .eq. ' ' .or. durq .eq. 'p') then
- dimen = dimen+.5
- else if (durq .eq. 'i') then
- dimen = dimen*72+.5
- else if (durq .eq. 'm') then
- dimen = dimen/25.4*72+.5
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal unit; must be "p","i",or"m"!')
- call stop1()
- end if
- if (charq .eq. 'h') then
- ptheight = int(dimen)
- else
- widthpt = int(dimen)
- end if
- end if
- else if (charq .eq. 'm') then
-c
-c Time signature change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Meter change only OK in voice 1, at start of block!')
- print*,'voice number is',ivx
- call stop1()
- end if
- newmeter = .true.
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- if (mtrnuml .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Digit 0 not allowed here!')
- call stop1()
-c else if (mtrdenl .eq. 1) then
-cc
-cc Kluge!!!
-cc
-c mtrdenl = 2
-c mtrnuml = 2*mtrnuml
- end if
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
-c
-c Read past printed time signature; not used in pmxa.
-c
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbar = lenmult*mtrnuml*lenbeat
- mtrnuml = 0
- else if (charq .eq. 'C') then
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
-c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then
- * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!')
- * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!')
- call stop1()
- end if
- gotclef = .true.
- else if (charq .eq. 'R') then
- if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Repeats can only go in voice 1!')
- call stop1()
- end if
-10 call g1etchar(lineq,iccount,durq)
- if (index('lrdDbz',durq) .gt. 0) go to 10
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "R" (repeat/double bar)!')
- call stop1()
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- if (iv .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Voltas are only allowed in voice #1!')
- call stop1()
- else if (isvolt) then
- print*
- print*,'*******WARNING********'
- write(15,'(/,a)')'*******WARNING********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There is more than one volta in this input block.!')
- print*,'This may work in a score, but WILL NOT work in parts.'
- print*,
- *'Safest to have only 1 volta per block, at the start of the block'
- write(15,'(a)')
- * 'This may work in a score, but WILL NOT work in parts.'
- write(15,'(a)')
- *'Safest to have only 1 volta per block, at the start of the block'
- end if
- isvolt = .true.
- lvoltxt = 0
-11 call g1etchar(lineq,iccount,durq)
- if (durq .ne.' ') then
- go to 11
- end if
- else if (charq .eq. 'B') then
- continue
- else if (charq .eq. 'P') then
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only allowed at beginning of block!')
- call stop1()
- end if
-16 call g1etchar(lineq,iccount,durq)
- if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and.
- * ichar(durq).le.57)) go to 16
- if (durq .eq. 'c') then
-c
-c Expect a centered name, and it has to be last option
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '"') then
-c
-c Quoted name, go to next quote mark
-c
- do 35 iccount = iccount+1 , 127
- if (lineq(iccount:iccount) .eq. '"') go to 36
-35 continue
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Missing close quote after page number command (P)!')
- call stop1()
-36 continue
- else if (durq .ne. ' ') then
-c
-c Space-delimited name, look for next blank
-c
- do 37 iccount = iccount+1 , 127
- if (lineq(iccount:iccount) .eq. ' ') go to 38
-37 continue
-38 continue
- end if
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "l","r","c" or digit allowed after "P"!')
- call stop1()
- end if
- else if (charq .eq. 'W') then
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1))
- else if (charq .eq. 'T') then
-c
-c Titles
-c
- call g1etchar(lineq,iccount,durq)
- if (index('itc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must put "i", "t", or "c" after "T"!')
- call stop1()
- end if
- ihead = ihead+2**(index('itc',durq)-1)
-c
-c Maybe a number after 'Tt', but ignore here. Read past string on next line.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else if (charq .eq. 'A') then
-27 call g1etchar(lineq,iccount,durq)
- if (index('rbsdeK',durq) .gt. 0) then
- go to 27
- else if (durq .eq. 'v') then
- if (ibarcnt .eq. 0) novshrinktop = .true.
- go to 27
- else if (durq .eq. 'a') then
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fbar)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'i') then
- call g1etchar(lineq,iccount,durq)
-c
-c Local interstaff correction. Set to -1. if not specifiec, or after use,
-c or anytime except at top, since pmxb handles all times except at top.
-c
- call readnum(lineq,iccount,durq,tintstf)
- if (ibarcnt .eq. 0) fintstf = tintstf
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'I') then
-c
-c Global interstaff correction. Use in place of fintstf if fintstf<0
-c
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'o') then
- optimize = .true.
- go to 27
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , nv
- call g1etchar(lineq,iccount,durq)
- if (index('-0st',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "AS", need nv instances of "s,t,-,0"!')
- call stop1()
- end if
- if (durq.eq.'-'.or.durq.eq.'s') then
- isize(iiv) = 1
- else if (durq.eq.'t') then
- isize(iiv) = 2
- end if
-50 continue
- go to 27
- else if (durq .eq. 'p') then
- fontslur = .false.
-42 continue
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,durq)
- if (index('shtc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only letters allowed here are "s","h","t","c"!')
- call stop1()
- end if
-c
-c Now check for another default modifier
-c
- go to 42
- else if (index('lh',durq) .gt. 0) then
-c
-c Flags for optional linebreak ties or header specials
-c
- go to 42
- else
- iccount = iccount-1
- end if
- go to 27
- else if (durq .eq. 'N') then
-c
-c Override default name for a part file. Must have part number, then
-c partname in quotes. Must be on line by itself, and start in column 1.
-c Will only be passed thru to scor2prt.
-c
- if (iccount .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must start in column 1!')
- call stop1()
- end if
- ndxquote = index(lineq,'"')
- if (ndxquote.lt.4 .or. ndxquote.gt.5 .or.
- * index('123456789',lineq(3:3)).eq.0 .or.
- * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must be followed by inst. #, then quote!')
- call stop1()
- end if
- ndxquote = index(lineq(ndxquote+1:128),'"')
- if (ndxquote .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In "AN", file name must be in quotes!')
- call stop1()
- end if
- iccount = 128
- else if (durq .eq. 'T') then
- cstuplet = .true.
- else if (durq .eq. 'R') then
-c
-c Get full name of normal include file; must occupy remainder of line
-c
- call getpmxmod(.false.,lineq(iccount+1:128))
- iccount = 128
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'After "A" must follow one of the letters abdeiINprsST!')
- * 'After "A" must follow one of the letters abdeiINprRsST!')
- call stop1()
- end if
- else if (charq .eq. 'K') then
-c
-c Rules and function of K command
-c
-c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is
-c initial sig, and must be passed to pmxb because it is needed when topfile
-c is called, which is before the K+n+m command is read in pmxb. Also, we
-c compute and save ibrkch and newkey for each syst, accounting for key changes,
-c then adjust fbar to make poenom much more accurate.
-c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('+-i',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"K" (transpose or key change) must be followed by "+,-,i"!')
- call stop1()
- end if
- if (durq .ne. 'i') then
-c
-c Normal key change and/or transposition)
-c
-c iccount = iccount+1
- num1 = 44-ichar(durq)
-c
-c num1= +1 or -1
-c
- ztrans = num1.eq.-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st +/- must be followed by a number!')
- call stop1()
- end if
-c iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = nint(fnum)*num1
- ztrans = ztrans .and. num1.eq.0
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st number after "K" must be followed by "+,-"!')
- call stop1()
- end if
- iccount = iccount+1
- num2 = 44-ichar(durq)
- call readnum(lineq,iccount,durq,fnum)
- num2 = num2*int(fnum+.1)
- if (num1.eq.0 .and. .not.ztrans) then
-c
-c Key change, only one per block allowed
-c
- if (iskchb) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one key change allowed per input block!')
- call stop1()
- end if
- iskchb = .true.
- nkeys = nkeys+1
- kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0
-c
-c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak.
-c
- ibrkch(nkeys) = ibarcnt+nbars
- if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1
- newkey(nkeys) = num2+idsig
- else
-c
-c Transposition
-c
- fulltrans = .true.
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Transposition must be at top of first input block!')
- call stop1()
- end if
- isig1 = num2
- idsig = isig1-newkey(1)
-c
-c idsig is the difference between sig after transposition, and sig in setup.
-c It may alter # of accid's in key changes if there is transposition.
-c
- end if
- else ! durq='i'
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here;
-c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
-c if (fulltrans) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Cannot yet combine full and instrument transposition!')
-c call stop1()
-c end if
- call GetiTransInfo(.true.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
- end if
- else if (charq .eq. '|') then
-c
-c Optional bar symbol
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar line marker out of place!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- else if (charq .eq. '/') then
- if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with repeated ornament still on!')
- ornrpt = .false.
- end if
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with sticky stemshrink still on!')
- stickyS = .false.
- end if
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block ended with forced beam open!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- else if (gotclef) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not enter clef at end of input block!')
- call stop1()
- end if
- barend = .false.
-c
-c Perform time checks
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not divisible by lenbar!')
- print*,'lenbar is ',lenbar
- call stop1()
- else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then
- print*
- print*,'# of bars in voice 1, current voice:',
- * itsofar(1)/lenbar,itsofar(ivx)/lenbar
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not equal to voice 1!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new voice
-c
- if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New voice is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c New voice is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- if (ivx .gt. nm) then
- write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm,
- * ' lines of music at once'
- call stop1()
- end if
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- do 24 j = 1 , 200
- rest(ivx,j) = .false.
- nacc(ivx,j) = 0
-24 continue
-c
-c For midi stuff, record that there is a 2nd line of music in this voice
-c
- if (ismidi) twoline(iv) = .true.
- end if
- end if
- iccount = 128
- else if (charq .eq. 'S') then
-c
-c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"S" can only be in first input block!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit must follow "S"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- nsyst = nint(fnsyst)
-14 continue
- if (durq .eq. 'P') then
-c
-c New npages for parts.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- npages = nint(fnsyst)
- go to 14
- else if (durq .eq. 'm') then
-c
-c Reset musize (musicsize).
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- musize = nint(fnsyst)
- wheadpt = whead20*musize
- go to 14
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in "S" symbol!')
- call stop1()
- end if
- else if (charq .eq. 'L') then
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+nbars+1
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced line break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,sysflb)
- isysflb(nflb) = nint(sysflb)
- if (nflb .gt. 1) then
-c
-c Check if new number is > prior one
-c
- if (isysflb(nflb) .le. isysflb(nflb-1)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You already forced a line break at a later line!')
- call stop1()
- end if
- end if
- if (npages .eq. 0) then
- print*
- print*,'WARNING! You forced a line break at line ',
- * isysflb(nflb),' but npage = 0. Continue?'
- read(*,'(a)') charq
- if (index('yY',charq) .eq. 0) call stop1()
- else if (isysflb(nflb) .gt. nsyst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced line break at line num > nsyst!')
- call stop1()
- else if (index(' PM',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have " ", "P", or "M" here!')
- call stop1()
- end if
- if (durq .eq. 'P') then
-c
-c Forced page break here, get page number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced page break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- nfpb = nfpb+1
- ipagfpb(nfpb) = nint(fnum)
- isysfpb(nfpb) = isysflb(nflb)
- if (ipagfpb(nfpb) .gt. npages) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break at page num > npages!')
- call stop1()
- else if (nfpb .gt. 1) then
- if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break numbers must increase!')
- call stop1()
- end if
- end if
- end if
- if (index(' M',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in linebreak symbol!')
- call stop1()
- else if (durq .eq. 'M') then
- nmovbrk = nmovbrk+1
- isysmb(nmovbrk) = isysflb(nflb)
- call g1etchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Vertical spacing, read past number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer required here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- go to 31
- else if (durq .eq. 'i') then
-c
-c Change indentation,
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Decimal number required here!')
- call stop1()
- end if
-c
-c fracsys was initialized in block data to all 0.'s
-c
- call readnum(lineq,iccount,durq,fracsys(nmovbrk))
- go to 31
- else if (durq .eq. 'c') then
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have "+" or "-" after "r" as movement break option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iorig in original list of instruments.
-c
- nv = 0
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number, get next two characters
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
-c
-c durq is a single digit number for noinow
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//
- * ' at movement break!')
- call stop1()
- end if
- ninow = ichar(durq)-48
- end if
- if (ninow.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New number of instruments must be <= original!')
- call stop1()
- end if
- do 63 iinow = 1 , ninow
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal 2-digit instrument number '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')iorig
- else
-c
-c durq is a single digit number for iorig
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal instrument number '//durq//
- * ' at movement break!')
- call stop1()
- end if
- iorig = ichar(durq)-48
- end if
- if (iorig .gt. noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New instrument number must be <= original noinst!')
- call stop1()
- end if
- nv = nv+nsperi(iorig)
-63 continue
- do 61 iiv = 1 , nv
-c
-c Get clef names
-c
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
- * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!')
- call stop1()
- end if
-c
-c Initialize new voices
-c
- nvmx(iiv) = 1
- ivmx(iiv,1) = iiv
- itsofar(iiv) = 0
- nnl(iiv) = 0
- do 62 j = 1 , 200
- rest(iiv,j) = .false.
-62 continue
-61 continue
-c
-c Loop back up, this might not be last option in M
-c
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after Movement break symbol!')
- call stop1()
- end if
- if (fracsys(nmovbrk) .lt. 0.001) then
-c
-c Since fracsys was not explicitly set, set it to prior value.
-c
- if (nmovbrk .eq. 1) then
- fracsys(nmovbrk) = fracindent
- else
- fracsys(nmovbrk) = fracsys(nmovbrk-1)
- end if
- end if
- end if
-c
-c Just before exiting if-block for forced line breaks, set counter to use when
-c dealing with vertical space calcs
-c
- nistaff(nflb) = nv-1
- else if (charq .eq. 'F') then
- usefig = .false.
- else if (charq .eq. 'X') then
- call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1,
- * udsp(ibarcnt+nbars+1),wheadpt)
- else if (charq .eq. 'I') then
-c
-c MIDI settings.
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MIDI stuff only allowed at start of block!')
- call stop1()
- end if
- if (nv .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry but MIDI does not work with more than 15 voices!')
- call stop1()
- end if
- ismidi = .true.
- call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,.true.)
- else if (charq .eq. 'M') then
- call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx,
- * nline)
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- else
- print*,'ASCII code:',ichar(charq)
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character is not allowed here!')
- print*,'ASCII code:',ichar(charq)
- call stop1()
- end if
- return
- end
- subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey,npages,nsyst,musize,bottreb)
- parameter(nm=24,maxblks=4000)
- character*65536 bufq
- character*1 chax
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*128 lineq
- logical lastchar,issegno,isheadr,isvolt,fbon,bottreb,
- * newway
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
-c
-c Get the first line
-c
- iccount = 0
- nline = 1
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') then
- nline = nline+1
- go to 9
- end if
- if (lineq(1:3) .eq. '---') then
-c
-c Have TeX input until next line that starts with '---'
-c
-3 nline = nline+1
- call getbuf(lineq)
- if (ilbuf .gt. nlbuf) go to 1
- go to 2
-1 print*,'You did not terminate type 0 TeX input with "---"'
- call stop1()
-2 continue
- if (lineq(1:3) .ne. '---') go to 3
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq and nline are first non-TeX lines.
-c
- nv = nint(readin(lineq,iccount,nline))
- if (nv .gt. nm) then
- write(*,'(1x,a46,i3)')
- * 'In setup data, number of voices cannot exceed',nm
- call stop1()
- end if
- noinst = nint(readin(lineq,iccount,nline))
- if (noinst .gt. nv) then
- write(*,'(a)')
- * 'In setup data, cannot have more instruments than staves'
- call stop1()
- end if
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 10 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
-10 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge!!!
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then
- write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8'
- call stop1()
- end if
- xmtrnum0 = readin(lineq,iccount,nline)
- newkey = nint(readin(lineq,iccount,nline))
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
- if (fracindent .ge. 1.) then
- write(*,'(a)')'In setup data, fracindent must be <1'
- call stop1()
- end if
- if (npages .gt. nsyst) then
- print*,'Error in input file: npages > nsyst'
- call stop1()
- else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then
- call printl('Musicsize must be 16, 20, 24, or 29')
- call stop1()
- end if
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , abs(noinst)
-5 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 5
-4 continue
-c
-c Mext non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 6
- do 7 iv = 1 , nv
-c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then
- if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then
- call errmsg(lineq,iv,0,
- * 'There should be a clef symbol here!')
- call stop1()
- end if
-7 continue
- if (lineq(nv+1:nv+1) .ne. ' ') then
- call errmsg(lineq,nv+1,0,
- * 'There should be a blank here!')
- call stop1()
- end if
-c
-c Set flag if voice 1 is treble, since it affects vertical spacing
-c
- bottreb = lineq(1:1).eq.'t'
-c
-c Mext non-comment line has path name
-c
-8 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 8
- lpath = index(lineq,' ')-1
- if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then
- call errmsg(lineq,lpath,0,
- * 'Last character of pathname is not "/",":", or "'
- * //chax(92)//'"!')
- call stop1()
- end if
- return
- end
- subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c
- logical notxtup,shifton,number,btest
- character*128 lineq
- character*1 charq,dumq
- number = .false.
- nPBSc = 0
-1 call g1etchar(lineq,iccount,charq)
- if (index('PBS:',charq) .gt. 0) then
-c
-c Continue checking here even if "P".
-c
- ipbsc = index('PBS:',charq)
- if (btest(nPBSc,ipbsc)) then
- call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!')
- call stop1()
-c else if (.not.notxtup .and. ipbsc.gt.2) then
-c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!')
-c call stop1()
- end if
- nPBSc = ibset(nPBSc,ipbsc)
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (index('+-',charq) .gt. 0) then
- call g1etchar(lineq,iccount,dumq)
- if (index('.0123456789',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibar,'Expected a number here!')
- call stop1()
- end if
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (charq.eq.'-') fnum = -fnum
- if (dumq .ne. 'p') then
- iccount = iccount-1
- fnum = fnum*wheadpt
- end if
- go to 1
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!')
- call stop1()
- end if
-c
-c Done with parsing. Other checks
-c
- if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Cannot have both "P" and "B" or "S" and ":"!')
- call stop1()
- end if
- if (btest(nPBSc,4)) then
- if (number) then
- if (shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Started a group shift without stopping prior one!')
- call stop1()
- else
- shifton = .true.
- end if
- else
- if (.not. shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Ended a group shift without starting one!')
- call stop1()
- else
- shifton = .false.
- end if
- end if
- end if
-c
-c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst)
-c
- if (iand(nPBSc,26).eq.0) udsp = udsp+fnum
- if (.not.number .and. .not.btest(nPBSc,4)) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Must have either a number or a colon in "X" symbol!')
- call stop1()
- end if
- return
- end
-c integer*4 function mytime()
-c CHARACTER(10) tq
-c CALL DATE_AND_TIME(TIME=tq)
-c read(tq,'(2i2,f6.3)')ih,im,ts
-c mytime = 1000*(ts+60*(im+60*ih))
-c return
-c end
- subroutine getbuf(lineq)
- parameter (maxblks=4000)
- character*(*) lineq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf))
- ipbuf = ipbuf+lbuf(ilbuf)
- ilbuf = ilbuf+1
- return
- end
- subroutine getchar(lineq,iccount,charq)
- parameter (nm=24)
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,equalize,stickyS
- character*1 charq,rptfq1,rptfq2
- character*128 lineq,lnholdq
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not. endmac) then
- iccount = 0
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call mrec1(lineq,iccount,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
-999 continue
- lastchar = .true.
- return
- end
- subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount)
- parameter (nm=24)
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 durq,chax
- character*4 dynsymq
- character*128 lineq
-c
-c Get info for dynamic mark. Enter after getting "D", iccount sits on "D"
-c Bits in idyndat are as follows
-c 00-03 ivx
-c 04-11 ip
-c 12-15 code for type of mark
-c 0 => arbitrary text
-c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff
-c If (.not. fontslur)
-c 13 => hairpin start, 14,15 => <,> (ending)
-c else
-c 13 < start, 14 > start, 15 ending
-c end if
-c 16 flag for vertical offset
-c 17-23 vertical offset + 64 , \internote
-c 31 Hairpin start (0), stop (1)
-c
-c idynda2
-c
-c 00 flag for horizontal offset
-c 01-09 (horizontal offset)/10 + 25.6 notehead widths
-c 10 5th bit for ivx (5/15/10)
-c
- irest = ibset(irest,26)
- ndyn = ndyn+1
- idyn = ivx
- idynda2(ndyn) = 0
- if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1)
- call setbits(idyn,8,4,ip)
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c text-dynamic
-c
- ntxtdyn = ntxtdyn+1
- iend = iccount+index(lineq(iccount+2:128),'"')+2
- txtdynq(ntxtdyn) = lineq(iccount+2:iend-2)
-c
-cc Store ivx, ip in bits 0-11
-c Store ivx, ip in bits 0-12
-c
-c ivxiptxt(ntxtdyn) = idyn
- ivxiptxt(ntxtdyn) = ivx+32*ip
- ipm = index('- +',lineq(iend:iend))
- idno = 0
- else
-c
-c Word-group or hairpin
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
-c
-c Exit the loop at first blank, "+", or "-"
-c
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ',
- * dynsymq)+3)/4
-c
-c Save for later down
-c
- idno1 = idno
- end if
-c
-c Set flag to check level later if in beam
-c
- iornq = ibset(iornq,23)
- if (idno.ge.14) then
-c
-c Hairpin here. Check if opposite type from one that's already on
-c
- if (idno.eq.14.and.btest(listdecresc,ivx) .or.
- * idno.eq.15.and.btest(listcresc,ivx)) then
- call printl(' ')
- call printl('Started one kind of hairpin while other is on')
- call stop1()
- end if
-c
-c Start or stop?
-c
- if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then
-c
-c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is.
-c
- if (.not.fontslur) idno = 15
- else if (fontslur) then
-c
-c Start of font slur
-c
- idno = 13
- else
-c
-c Start of postscript slur
-c
- idno = idno-1
- end if
- end if
-c
-c Now that we used list[de]cresc, update
-c
- if (idno .ge.13) then
- if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then
-c
-c Something's ending
-c
- if (btest(listcresc,ivx)) then
-c
-c It's a cresc!
-c
- listcresc = ibclr(listcresc,ivx)
- else
- listdecresc = ibclr(listdecresc,ivx)
- end if
- else
-c
-c Something's starting
-c
- if (idno1 .eq. 14) then
-c
-c It's a cresc!
-c
- listcresc = ibset(listcresc,ivx)
- else
- listdecresc = ibset(listdecresc,ivx)
- end if
- end if
- end if
- call setbits(idyn,4,12,idno)
- iccount = iend
- if (ipm .ne. 2) then
-c
-c There is a vertical shift
-c
- idyn = ibset(idyn,16)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- call setbits(idyn,7,17,(ipm-2)*idno+64)
- ipm = index('- +',durq)
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
-c idynda2(ndyn) = ibset(idyn,23)
- idynda2(ndyn) = ibset(idynda2(ndyn),0)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256)
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- idyndat(ndyn) = idyn
- return
- end
- subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig,
- * itsofar,nodur,figq,ivupfig,nfigs)
- logical isfig
- character*1 charq
- character*10 figq
- character*128 lineq
-c
-c As of 11/26/08, trapped extra figures in getnote, so no need here.
-c
-c if (ivx .gt. 2) then
-cc
-cc Read past the figure
-cc
-c6 call getchar(lineq,iccount,charq)
-c if (charq .ne. ' ') go to 6
-c return
-c end if
- nfigs = nfigs+1
- ivupfig = 0
- itoff = 0
- if (charq .eq. 'x') then
-c
-c Floating figure.
-c
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')noff
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')loff
- itoff = noff*ifnodur(loff,'x')
- call getchar(lineq,iccount,charq)
- else
-c
-c Figure on a note
-c
- isfig = .true.
- end if
- itfig = itsofar+itoff-nodur
- lfig = 1
- figq = charq
-5 call getchar(lineq,iccount,charq)
-c if (charq .ne. ' ') then
- if (index(' +',charq) .eq. 0) then
- figq = figq(1:lfig)//charq
- lfig = lfig+1
- go to 5
- else if (charq .eq. '+') then
-c
-c Get vertical offset for figure. Next character after number has to be blank.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ivupfig = nint(fnum)
- end if
- return
- end
- subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- parameter (nm=24)
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg
- character*1 charq,durq
- character*20 voltxtq
- character*128 lineq,litq
- integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm),
- * ndlev(nm,2)
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
- ngrace = ngrace+1
- ivg(ngrace) = ivx
- ipg(ngrace) = nnl(ivx)+1
- if (ngrace .eq. 1) then
- ngstrt(ngrace) = 1
- else
- ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
- end if
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
- nng(ngrace) = 1
- multg(ngrace) = 1
- upg(ngrace) = .true.
- slurg(ngrace) = .false.
- slashg(ngrace) = .false.
-18 call getchar(lineq,iccount,charq)
- if (index('WA',charq) .gt. 0) then
-c
-c Grace is on note that was already done, so shift flags forward one note.
-c This puts flag on actual note with grace; later for W will go ahead one more.
-c
- ipg(ngrace) = nnl(ivx)
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
- if (slurg(ngrace))
- * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
- if (charq .eq. 'A') then
-c
-c close After, clear way-after bit, to ensure priority of most recent A/W
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
- else
-c
-c Way after; later assign to following note, and position like normal grace.
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
- end if
- else if (charq .eq. 'm') then
- call getchar(lineq,iccount,charq)
- multg(ngrace) = ichar(charq)-48
- else if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- nng(ngrace) = nint(fnum)
- else if (charq .eq. 'l') then
- upg(ngrace) = .false.
- else if (charq .eq. 's') then
- slurg(ngrace) = .true.
- if (nnl(ivx) .gt. 0) then
-c
-c If A- or W-grace, set signal to start slur on main note.
-c
- if(btest(ipl(ivx,nnl(ivx)),31) .or.
- * btest(ipl(ivx,nnl(ivx)),29))
- * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
- end if
- else if (charq .eq. 'x') then
- slashg(ngrace) = .true.
- else if (charq .eq. 'u') then
- else if (charq .eq. 'X') then
-c
-c Space before main note of grace. Number will come next.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,graspace(ngrace))
- iccount = iccount-1
- end if
- if (index('abcdefg',charq) .eq. 0) go to 18
-c
-c At this point, charq is first note name in grace
-c
- do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
- naccg(ing) = 0
- ioct = 0
- if (ing .gt. ngstrt(ngrace)) then
-55 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- endif
- iclastlev = 0
-9 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- iclastlev = iclastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- iclastlev = iclastlev-7
- else if (index('fsn',durq) .gt. 0) then
- if (naccg(ing) .eq. 0) then
- naccg(ing) = index('fsn',durq)
- else
-c
-c Double accidental
-c
- naccg(ing) = ibset(naccg(ing),2)
- end if
- else
- ioct = ichar(durq)-48
- end if
- go to 9
- end if
- if (ioct .gt. 0) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- lastlev = ndlev(iv,kv)+iclastlev
- end if
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- nolevg(ing) = lastlev
-19 continue
-c
-c Grace could come before first note of block, so reset end level.
-c
- if (nnl(ivx).eq.0) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- ndlev(iv,kv) = lastlev
- end if
- return
- end
- subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
-cccccccccccccccccccccccc
-cc
-cc GetiTransInfo.for
-cc
-cccccccccccccccccccccccc
-c
-c Called from both g1etnote and getnote, after first 'i' in Ki[...]
-c On entry, iccount points to last char retrieved, which is 'i'
-c
-c From1: locgical, true if called from g1etnote
-c ibarcnt: tells whether to set EarlyTransOn to true.
-c EarlyTransOn set false in blkdata, true here, back to false in topfile.
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote;
-c LaterInstTrans from getnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
-c iTransAmt stored as fn of instrument #, not like iTransKey which is
-c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This
-c simplifies use of iTransAmt for all calls to ifnolev.
-c
- parameter (nm=24)
- logical From1
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans,store
- character*128 lineq
- character*1 durq
- durq = 'x' ! Can't initialize in declaration stmt, only works once.
- if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0
- store = (EarlyTransOn.and.ibarcnt.eq.0) .or.
- * (ibarcnt.gt.0.and..not.From1)
- LaterInstTrans = .not.From1 .and. ibarcnt.gt.0
- if (store) nInstTrans = 0
-1 continue
- if (durq .eq. ' ') return
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be an instrument number here!')
- call stop1()
- end if
- if (store) nInstTrans = nInstTrans+1
- call readnum(lineq,iccount,durq,fnum)
- instn = nint(fnum)
- if (instn.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Instrument number out of range!')
- call stop1()
- end if
- if (store) iInstTrans(nInstTrans) = instn
-c
-c durq is +/- following inst # (for iTransAmt), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after instrument number must be "+,-"!')
- call stop1()
- end if
- itramt = 44-ichar(durq) ! +1/-1 for itramt
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a transposition amount here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransAmt(instn) = nint(fnum)*itramt
-c
-c durq is +/- following iTransAmt (for iTransKey), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after transposition amount must be "+,-"!')
- call stop1()
- end if
- ikey = 44-ichar(durq) ! +1/-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a key indicator here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransKey(nInstTrans) = nint(fnum)*ikey
-c
-c durq is now 1st character after iTransKey, should be either 'i' or ' '
-c
- if (durq.ne.'i'.and.durq.ne.' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be blank or "i" here!')
- call stop1()
- end if
- go to 1
- end
- subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,first)
-c
-c Use this from both pmxa and pmxb to input and check midi data. "first" tells
-c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause
-c things to be written immediately into the midi storage buffers.
-c
- parameter (nm=24,mv=24576)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
- integer*2 mmidi,midinum(26)
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- character*1 durq
- character*2 instq
- character*128 lineq
- logical first
- common /comdiag/ n69(0:nm),n34(0:nm)
-c
-c Instrument codes
-c
- data midinum
- * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67,
-c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX
-c
- * 68,69,71,72,74,75, 8,55 /
-c bsXobXbaXclXflXreXctXvo
-c
-1 call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Tempo in beats ber minute
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the pause!')
- call stop1()
-c else if (mmacrec) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Cannot change MIDI tempo while recording a MidiMacro!')
-c call stop1()
- end if
- call readnum(lineq,iccount,durq,qpm)
- iccount = iccount-1
- if (.not.first) then
- call midievent('t',nint(qpm),0)
- gottempo = .true.
- end if
- go to 1
- else if (durq .eq. 'p') then
-c
-c Insert a pause. pausemid = pause in 1/4's
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here for the pause!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,pausemid)
- iccount = iccount-1
- if (.not.first) then
-c
-c Compute a meter for the pause. This is only to keep MidiNotate on track.
-c Round pause to nearest 16th. Let denominator always be 16.
-c
- numb16 = nint(pausemid*4)
- call midievent('m',numb16,16)
-c
-c Put in pausemid beats of rest
-c
- do 3 icm = 0 , numchan-1
- call addmidi(icm,0,0,0,4.*numb16,.true.,.false.)
-3 continue
- miditime = miditime+nint(240*pausemid)
-c
-c Restore meter
-c
- call midievent('m',mtrdenl*lenbar/64,mtrdenl)
- end if
- go to 1
- else if (durq .eq. 'i') then
-c
-c Instrument numbers or letters. Expect nv of them.
-c
- do 2 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (ichar(durq) .gt. 96) then
-c
-c It's a lowercase letter. Get another, find corr. instrument #.
-c
- instq(1:1) = durq
- call getchar(lineq,iccount,durq)
- instq = instq(1:1)//durq
- iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'//
- * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3
- if (iname .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unrecognized 2-letter midi instrument name!')
- call stop1()
- end if
- midinst(ivx) = midinum(iname)-1
- else
-c
-c Expect a number, followed by ":" if that is followed by another number.
-c I.e., if after call to readnum, durq is not ":", it must be either blank
-c or next instrument letter.
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi instrument number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midinst(ivx) = nint(fnum)-1
- if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi instrument number must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
- end if
-2 continue
- go to 1
- else if (durq .eq. 'v') then
-c
-c Get volumes for each instrument. Expect nv of them.
-c Follow same pattern as for insttrument numbers above.
-c
- do 7 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi velocity number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midivel(ivx) = nint(fnum)-1
- if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi velocity must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-7 continue
- go to 1
- else if (durq .eq. 'b') then
-c
-c Get balance for each instrument. Expect nv of them.
-c Follow same pattern as for instrument numbers above.
-c
- do 8 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a balance number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midibal(ivx) = nint(fnum)-1
- if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi balance must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-8 continue
- go to 1
- else if (durq .eq. 'T') then
-c
-c Get transposition for each instrument. Expect nv of them.
-c Follow similar pattern as above, but separator is +|-.
-c
- do 9 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- ipm = index('-+',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" for midi transposition here!')
- call stop1()
- end if
- ipm = 2*ipm-3
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- miditran(ivx) = ipm*nint(fnum)
-c if (mod(miditran(ivx),12).ne. 0) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Midi transposition limited to multiples of 12!')
-c call stop1()
-c end if
- iccount = iccount-1
-9 continue
- go to 1
- else if (durq .eq. 'g') then
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the midi gap!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mgap = nint(fnum)
- iccount = iccount-1
- go to 1
- else if (durq .eq. 'M') then
-c
-c MidiMacros
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'R') then
-c
-c Start recording
-c
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to record a MidiMacro while already recording!')
- call stop1()
- end if
- mmacrec = .true.
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (immac .gt. 20) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MidiMacro ID cannot exceed 20!')
- call stop1()
- end if
-c
-c Save the start time
-c
- mmactime(immac) = miditime
- do 4 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
-c
-c Adjust if there's a rest at end of prior section. Insert dummy turnoff.
-c (This causes two turn-offs in a row, which testmidi sees as an error).
-c
-c Before: section1 ------rest------- section2(to be recorded)
-c After: section1 rest1 now rest2 section2(recorded)
-c
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacstrt(icm,immac) = imidi(icm)+1
-4 continue
- end if
- go to 1
- else if (index('123456789P',durq) .eq. 0) then
-c
-c End recording; close the open macro. Get immac from common.
-c
- if (.not.mmacrec) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You tried to end a MidiMacro before starting one!')
- call stop1()
- end if
- mmacrec = .false.
- iccount = iccount-1
- if (.not.first) then
-c
-c Save the macro duration
-c
- mmactime(immac) = miditime-mmactime(immac)
- do 5 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track if needed.
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacend(icm,immac) = imidi(icm)
-5 continue
- end if
- if (durq .ne. ' ')go to 1
- else if (durq .eq. 'P') then
-c
-c Play Back a Macro
-c
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to play a MidiMacro before ending recording!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (mmactime(immac) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a MIDI macro before recording it!')
- call stop1()
- end if
- do 6 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0.
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- end if
- end if
- msecend(icm,nmidsec) = imidi(icm)
- msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac)
- msecend(icm,nmidsec+1) = mmacend(icm,immac)
- msecstrt(icm,nmidsec+2) = imidi(icm)+1
-6 continue
- nmidsec = nmidsec+2
-c
-c Update running time
-c
- miditime = miditime+mmactime(immac)
- lasttime = miditime
- end if
- go to 1
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MidiMacro sub-command!')
- call stop1()
- end if
- else if (durq .eq. 'd') then
- debugmidi = .true.
- go to 1
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MIDI input data!')
- call stop1()
- end if
- if (.not.gottempo .and. .not.first) then
-c
-c If no tempo is set on first call on the pmxb pass, then set it
-c
- call midievent('t',96,0)
- gottempo = .true.
- end if
- return
- end
- subroutine getnote(loop)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*10 figq
- character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax
- logical beamon,firstgulp,figbass,figchk,isfig
- character*60 cheadq
- character*120 instrq,titleq,compoq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp,
- * was2,nobar1,quoted,isbj2,stickyS,
- * OptLineBreakTies,HeaderSpecial
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /combc/ bcspec
- common /comas3/ ask(2500),iask,topmods
-c
-c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined
-c ivx is current ivmx, and is the index for all notes, acc's etc.
-c
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comtrans/ cheadq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- common /comclefq/ clefq(nm)
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- character*128 txtdynq
- logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur,
- * fontslur,WrotePsslurDefaults
- character*128 lineq,lnholdq
- character*80 headrq, lowerq
- character*79 inameq
- character*59 hdlndq
- character*20 voltxtq
- character*1 charq,dotq,durq,ulfbq,dumq
- logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved,
- * topmods,headlog,btest,sluron,cdot,equalize
- character*24 tempq
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1,
- * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3
- logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3
- common /combibarcnt/ ibarcnt
- cdot = .false.
-1 call getchar(lineq,iccount,charq)
- if (lastchar) return
- if (charq .eq. ' ') go to 1
- if (charq .eq. '%') then
-c
-c Check for a bar number format:
-c
- if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and.
- * index('bB1234567890',lineq(3:3)).gt.0) then
- if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128))
- end if
- iccount = 128
- go to 1
- end if
-c
-c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r'
-c
- if (rptprev) then
- rptnd1 = charq .eq. '/'
- rptprev = .false.
- end if
-c
-c Repeat at end of a piece
-c
- if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- * charq.eq.'r') then
- if (cdot) go to 28
-c
-c This is a note/rest.
-c
- idotform = 0
- numnum = 0
-c
-c If start of line of music, set pitch from previous
-c
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv)
-c
-c notcrd is used to tell if orn. goes on main note or chord note
-c
-c notcrd = .true. !Move dow. Was not observed if dotted shortcut.
-c
-c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts.
-c
-28 continue
-c
-c Moved this from just above, 2 Feb 02
-c
- notcrd = .true.
- nnl(ivx) = nnl(ivx)+1
- if (ornrpt) then
-c
-c Replicate ornament bits, also bit 23 for beam handling if chord.
-c
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- if (stickyS) then
-c
-c Grab stemlength shortening parameters from prior note
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
- call setbits (mult(ivx,nnl(ivx)),3,28,
- * igetbits(mult(ivx,nnl(ivx)-1),3,28))
- end if
- if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then
-c
-c Doing auto forced beams, and period has been set, so check if this note
-c starts a period.
-c
-c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Start a forced beam here
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- end if
- end if
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
- dotq = 'x'
- if (charq.eq.'r')
- * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (btest(irest(ivx,nnl(ivx)),0)) then
-c
-c Rest stuff. First check if previous note was full-bar-pause
-c
- if (lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1) then
- if (btest(islur(ivx,nnl(ivx)-1),19))
- * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- end if
-c
-c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2
-c for voice a or b. Set a-types at 0 as encountered and adjust later
-c after '//'. (Override heights will be set to 100+offset)
-c
- if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- end if
-2 call getchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- ioct = ic-48
- numnum = 2
- go to 2
- else
- print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx)
- call stop1()
- end if
- else if (durq .eq. 'd') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
-c
-c Double dot.
-c
- iccount = iccount+1
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3)
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0)
- * go to 2
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
- call getchar(lineq,iccount,durq)
- ndotmv(ivx) = ndotmv(ivx)+1
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx)))
- if (durq .eq. '-')
- * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx))
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx)))
- if (dumq .eq. '-')
- * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx))
- else
- rtdot(ivx,ndotmv(ivx)) = 0.
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. 'p') then
-c
-c Full-bar rest as pause
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'b') then
-c
-c Blank rest
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Accidental
-c
- if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c
-c No accidental has been set yet
-c
- nacc(ivx,nnl(ivx)) = index('fsn',durq)
- else
-c
-c Repeated accid, so must be double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- go to 2
- else if (durq .eq. 'i') then
-c
-c Set flag for MIDI-only accidental.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- go to 2
- else if (index('+-<>',durq) .gt. 0) then
- ipm = index('- +',durq)-2
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
-c
-c A note, not a rest.
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (moved) go to 2
-c
-c Octave jump with a note
-c
- if (numnum .lt. 2) then
- lastlev = lastlev+ipm*7
- else
- ioct = ioct+ipm*1
- end if
- go to 2
- else
-c
-c Override default height of a rest
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (lineq(iccount-1:iccount-1) .eq. '.') then
-c
-c Kluge in case there is a shortcut ".". It will have been sucked up by
-c readnum. (Same doesn't hold for ",")
-c
- iccount = iccount-2
- go to 2
- end if
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
-c
-c There may be more characters for this rest
-c
- iccount = iccount-1
- go to 2
- end if
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Will set all durations to 0 except last one. Set flag on this note.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28)
-c
-c Next input will be digit
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- ntup = nint(fnum)
- if (index('DF',durq) .gt. 0) then
-c
-c Double xtup note to make an un= xtup. Here xtup number already set but may also
-c have this command before.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = 1
- call getchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- end if
-c
-c Only other possibilities here are ' ' or 'n'
-c
- if (durq .eq. 'n') then
-c
-c Alter xtup number
-c
- if (lineq(iccount+1:iccount+1) .eq. ' ') then
-c
-c If the only modifier is 'n', cancel the number
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31)
- else
- numshft = 0
-30 call getchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
-c
-c Flip up-down-ness
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14)
- go to 30
- else if (index('+-',durq) .gt. 0) then
-c
-c Vertical or horiz shift
-c
- numshft = numshft+1
- iofforn = 1
- if (durq .eq. '-') iofforn = -1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- if (numshft .eq. 1) then
-c
-c Vertical shift
-c
- iofforn = iofforn*nint(xofforn) + 16
-c
-c Turn on bit 1; set bits 2-6 to iofforn
-c
- irest(ivx,nnl(ivx)) =
- * ior(irest(ivx,nnl(ivx)),2+4*iofforn)
- else
-c
-c Horizontal shift
-c
- iofforn = iofforn*nint(xofforn*10)+16
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7)
- call setbits(irest(ivx,nnl(ivx)),5,9,iofforn)
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope adjustment for bracket
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4)
- call getchar(lineq,iccount,durq)
- iofforn = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- iofforn = nint(iofforn*xofforn+16)
- call setbits(mult(ivx,nnl(ivx)),5,5,iofforn)
- else if (index('123456789',durq) .gt. 0) then
-c
-c Replacement printed number
-c
- call readnum(lineq,iccount,durq,xofforn)
- call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn))
- iccount = iccount-1
- go to 30
- end if
- end if
- end if
-c
-c Set note level of 1st note of xtup, provided not a rest
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- end if
- do 40 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on starting note of xtuplet
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-40 continue
- numnum = 0
- nodur(ivx,nnl(ivx)) = 0
- do 6 itup = 2 , ntup
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- nnl(ivx) = nnl(ivx)+1
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
-7 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') then
- go to 7
- else if (charq .eq. '%') then
- iccount = 128
- go to 7
- else if (charq .eq. 'o') then
-c
-c Ornament in xtuplet. "o" symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx)-1)
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1),
- * iornq(ivx,0),ornrpt,noffseg,
- * nnl(ivx)-1,ivx,.false.,notcrd,nole)
- go to 7
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)-1
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detected preslur in xtuplet loop, non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t') islur(ivx,nnlivx) =
- * ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- go to 7
- else if (charq .eq. 'G') then
-c
-c Kluge to get grace in xtup at right location
-c
- nnl(ivx) = nnl(ivx)-1
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- nnl(ivx) = nnl(ivx)+1
- go to 7
- else if (charq .eq. sq) then
- call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
- go to 7
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c Figure. Must come AFTER the first note of xtup
-c
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx),
- * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf))
- go to 7
- else if (charq .eq. 'X') then
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx,
- * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur,
- * dotq,ndoub)
- go to 7
- else if (charq .eq. 'z') then
-c
-c Chord note in xtup. Goes with *prior* note.
-c
- notcrd = .false.
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)-1
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-34 call getchar(lineq,iccount,durq)
-c
-c When chord note is done, will get ' ', making ndx=0, so go past this block
-c
- ndx = index('fsn+-<>12345678reic',durq)
- if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (ndx .eq. 19) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)-1) =
- * ibset(iornq(ivx,nnl(ivx)-1),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,
- * igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,
- * igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)-1) =
- * ibset(irest(ivx,nnl(ivx)-1),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else
-c
-c must be a number, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 34
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 41 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on chord note in xtup
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Following lines copied from loop for non-xtup, chord note, preslur
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0)
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0)
- isdat2(nsdat-npreslur+1) =
- * ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-41 continue
- go to 7
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)-1),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)-1
- ArpShift(NumArpShift) = fnum
- end if
- go to 7
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1),
- * iornq(ivx,nnl(ivx)-1),lineq,iccount)
- go to 7
-c+++
- else if (charq .eq. ']') then
-c
-c Multiplicity up-down, must have '][ '
-c
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20)
- iccount = iccount+2
- go to 7
-cc+++
- end if
-c
-c End of loop for xtup options. If here, charq must be a (non-crd) note name.
-c or rest
-c
- if (charq .eq. 'r') then
-c
-c Rest in xtup
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'b') then
-c
-c Blank rest in middle of xtup
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- else
-c
-c Override height of embedded xtup rest
-c
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
- iccount = iccount-1
- end if
- else if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- end if
- notcrd = .true.
-8 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (index('+-<>',durq) .gt. 0) then
-c
-c Accidental horizontal shift
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (.not.moved) then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- end if
- end if
- else if (index('fsn',durq) .gt. 0) then
- if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c
-c No accid set yet
-c
- nacc(ivx,nnl(ivx)) = index('fsn',durq)
- else
-c
-c Symbol must be repeated, so it's a double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- else if (durq .eq. 'i') then
-c
-c Set flag for midi-only accidental
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
-
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (index('ul',durq) .gt. 0) then
-c
-c Force stem direction for non-beamed xtup note
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- else if (durq .eq. 'e') then
-c
-c Left-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
-c
-c Right-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = ndoub+1
- else if (durq .eq. 'd') then
-c
-c Dotted xtup note
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- else
-c
-c Must be an octave number
-c
- lastlev = ifnolev(charq,ichar(durq)-48
- * ,iTransAmt(instno(iv)))
- end if
- go to 8
- end if
- if (itup .lt. ntup) then
-c
-c Last note is handled *after* flowing out of the xtup if block, but still
-c within block for a note-rest. Set note level now (rest already done).
-c Could have problem here if rests & doubled notes are combined in xtup,
-c since might exit the loop at the wrong place. Worry about it later.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- lastlev = lastlev-3+mod(ifnolev(charq,10,
- * iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- nodur(ivx,nnl(ivx)) = 0
- do 42 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on internal xtup note
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-42 continue
- end if
- if (itup .eq. ntup-ndoub) go to 12
-6 continue
-12 continue
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
-c
-c End of if-block for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c For some purposes, pretend its one bar only
-c
- nodur(ivx,nnl(ivx)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
- xb4mbr = 0.
-20 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48.and.ichar(durq).le.57) then
- mbrest = 10*mbrest+ichar(durq)-48
- go to 20
- end if
- else if (index('ul',durq) .gt. 0) then
-c
-c Set stem flipper
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'a') then
-c
-c "Alone", i.e., prohibit beam
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'r') then
-c
-c Right offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- go to 2
- else if (durq .eq. 'e') then
-c
-c Left offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- go to 2
- else if (durq .eq. 'S') then
-c
-c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4
-c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to
-c interbeams = internotes*2/3.
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c End stickyS. Grab data now from prior note, since we have to shut off stickyS.
-c
- call setbits (mult(ivx,nnl(ivx)),3,28,
- * igetbits(mult(ivx,nnl(ivx)-1),3,28))
- stickyS = .false.
- go to 2
- end if
-c
-c If durq .ne. ':' then iccount is now on the start of the number
-c
- call readnum(lineq,iccount,durq,dum)
- call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2))
- if (durq .eq. ':') then
- stickyS = .true.
- else
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. ',') then
-c
-c 2:1 pattern
-c
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. 'o') then
-c
-c Suppress rest centering
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25)
- go to 2
- else if (durq .eq.'L') then
-c
-c With keyboard rest option, look left
-c
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30)
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Accidental option
-c
- call getchar(lineq,iccount,durq)
-c
- if (durq .eq. 'o') then
-c
-c Ordered accidentals in a chord. Mark the main note.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28)
- else
-c
-c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29)
- iccount = iccount-1
- end if
- go to 2
- else if (durq .ne. ' ') then
- print*,'Illegal character in note: ',durq,', ivx,nn:',
- * ivx,nnl(ivx)
- call stop1()
- end if
-c
-c Done with note/rest options. Set level and duration.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- do 43 npreslur = npreslur , 1 , -1
-c
-c Set level for preslur on normal note, non-chord
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-43 continue
- end if
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (btest(islur(ivx,nnl(ivx)),19)) then
-c
-c Set duration of full-bar rest as pause
-c
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- else if (ibarmbr.ne.nbars+1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- if (btest(islur(ivx,nnl(ivx)),3))
- * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- end if
- if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then
-c
-c Shift is on, and this is not first shifted note. Check for duration change
-c
- if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then
-c
-c Must stop and restart the offset.
-c
- irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1)
- end if
- end if
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (autofbon .and. tautofb.gt.tol .and. fbon) then
-c
-c Check to see if need to terminate auto forced beam
-c
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Terminate autofb
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- end if
- end if
- if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then
-c
-c Finished a bar
-c
- nbars = nbars+1
- nib(ivx,nbars) = nnl(ivx)
- if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then
-c
-c Just finished the pickup bar for this voice.
-c
- lenbar = lenb1
- end if
- end if
- if (idotform .eq. 1) then
- call getchar(lineq,iccount,charq)
- idotform = 2
- numnum = 1
- go to 28
- else if (idotform .eq. 3) then
- call getchar(lineq,iccount,charq)
- idotform = 4
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
-c
-c Chord note. Must have note name, may have octave#,+,-,s,f,n,d
-c Actually the 'd' is not used, since time value comes from
-c basic note. Unless dot is to be shifted!
-c Doesn't increase # of notes, so must handle separately
-c ncrd: index of crd
-c Set bit 10 of ipl on main note as flag
-c Bits in icrdat:
-c 0-7 ip within voice
-c 8-11 ivx
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Cautionary accidental
-c
-c Bits in icrdot:
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdot(ncrd) = 0
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-25 call getchar(lineq,iccount,durq)
-c ndx = index('fsn+-<>12345678rediA',durq)
- ndx = index('fsn+-<>12345678rediAc',durq)
- if (ndx .eq. 20) then
-c
-c Expect +|-|<|> , set tag, loop
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),29)
- go to 25
- else if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (ndx .eq. 21) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental on chord note
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else if (durq .eq. 'd') then
-c
-c Must keep 'd' optional (backward compatibility), unless it is moved!
-c
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2))
- * .eq. 0) go to 25
- icrdat(ncrd) = ibset(icrdat(ncrd),26)
- call getchar(lineq,iccount,durq)
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '+') then
- icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64)
- else
- icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64)
- end if
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift specified also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '+') then
- ifnum = nint(fnum*10)+64
- else
- ifnum = -nint(fnum*10)+64
- end if
- else
- ifnum = 64
- end if
- icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7))
- iccount = iccount-1
- end if
- else
-c
-c must be a single digit, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 25
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 44 npreslur = npreslur , 1 , -1
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Set level for chord note.
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0)
- isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-44 continue
- if (notcrd) then
-c
-c This is the first chord note in this chord.
-c
- minlev = min(nolev(ivx,nnl(ivx)),lastlev)
- maxlev = max(nolev(ivx,nnl(ivx)),lastlev)
- else
- minlev = min(minlev,lastlev)
- maxlev = max(maxlev,lastlev)
- end if
- notcrd = .false.
- else if (charq .eq. 'G') then
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- continue
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
-c ngrace = ngrace+1
-c ivg(ngrace) = ivx
-c ipg(ngrace) = nnl(ivx)+1
-c if (ngrace .eq. 1) then
-c ngstrt(ngrace) = 1
-c else
-c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
-c end if
-c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
-c nng(ngrace) = 1
-c multg(ngrace) = 1
-c upg(ngrace) = .true.
-c slurg(ngrace) = .false.
-c slashg(ngrace) = .false.
-c18 call getchar(lineq,iccount,charq)
-c if (index('WA',charq) .gt. 0) then
-cc
-cc Grace is on note that was already done, so shift flags forward one note.
-cc This puts flag on actual note with grace; later for W will go ahead one more.
-cc
-c ipg(ngrace) = nnl(ivx)
-c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
-c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
-c if (slurg(ngrace))
-c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
-c if (charq .eq. 'A') then
-cc
-cc close After, clear way-after bit, to ensure priority of most recent A/W
-cc
-c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
-c else
-cc
-cc Way after; later assign to following note, and position like normal grace.
-cc
-c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
-c end if
-c else if (charq .eq. 'm') then
-c call getchar(lineq,iccount,charq)
-c multg(ngrace) = ichar(charq)-48
-c else if (index('123456789',charq) .gt. 0) then
-c call readnum(lineq,iccount,durq,fnum)
-c iccount = iccount-1
-c nng(ngrace) = nint(fnum)
-c else if (charq .eq. 'l') then
-c upg(ngrace) = .false.
-c else if (charq .eq. 's') then
-c slurg(ngrace) = .true.
-c if (nnl(ivx) .gt. 0) then
-cc
-cc If A- or W-grace, set signal to start slur on main note.
-cc
-c if(btest(ipl(ivx,nnl(ivx)),31) .or.
-c * btest(ipl(ivx,nnl(ivx)),29))
-c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
-c end if
-c else if (charq .eq. 'x') then
-c slashg(ngrace) = .true.
-c else if (charq .eq. 'u') then
-c else if (charq .eq. 'X') then
-cc
-cc Space before main note of grace. Number will come next.
-cc
-c iccount = iccount+1
-c call readnum(lineq,iccount,durq,graspace(ngrace))
-c iccount = iccount-1
-c end if
-c if (index('abcdefg',charq) .eq. 0) go to 18
-cc
-cc At this point, charq is first note name in grace
-cc
-c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
-c naccg(ing) = 0
-c ioct = 0
-c if (ing .gt. ngstrt(ngrace)) then
-c55 call getchar(lineq,iccount,charq)
-c if (charq .eq. ' ') go to 55
-c endif
-c iclastlev = 0
-c9 call getchar(lineq,iccount,durq)
-c if (durq .ne. ' ') then
-c if (durq.eq.'+') then
-c lastlev = lastlev+7
-c iclastlev = iclastlev+7
-c else if (durq.eq.'-') then
-c lastlev = lastlev-7
-c iclastlev = iclastlev-7
-c else if (index('fsn',durq) .gt. 0) then
-c if (naccg(ing) .eq. 0) then
-c naccg(ing) = index('fsn',durq)
-c else
-cc
-cc Double accidental
-cc
-c naccg(ing) = ibset(naccg(ing),2)
-c end if
-c else
-c ioct = ichar(durq)-48
-c end if
-c go to 9
-c end if
-c if (ioct .gt. 0) then
-c lastlev = ifnolev(charq,ioct)
-c else
-c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
-c if (ivx .le. nv) then
-c kv = 1
-c else
-c kv = 2
-c end if
-c lastlev = ndlev(iv,kv)+iclastlev
-c end if
-c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
-c end if
-c nolevg(ing) = lastlev
-c19 continue
-cc
-cc Grace could come before first note of block, so reset end level.
-cc
-c if (nnl(ivx).eq.0) then
-c if (ivx .le. nv) then
-c kv = 1
-c else
-c kv = 2
-c end if
-c ndlev(iv,kv) = lastlev
-c end if
- else if (charq .eq. sq) then
-c
-c Literal TeX string
-c
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. Symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx))
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)),
- * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx,
- * .true.,notcrd,nole)
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detect preslur on normal non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t')
- * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)
- ArpShift(NumArpShift) = fnum
- end if
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
-
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx),
- * nodur(ivx,nnl(ivx)),figq(ivf,nfig1),
- * ivupfig(ivf,nfig1),nfigs(ivf))
- else if (charq .eq. '[') then
-c
-c Start forced beam. Record barno & time since start of inp. blk. Set signal
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- nadj = 0
- if (autofbon) then
- autofbon = .false.
- end if
-17 call getchar(lineq,iccount,charq)
- if (index('ulf',charq) .gt. 0) then
- ulfbq(ivx,nfb(ivx)) = charq
- go to 17
- else if (charq .eq. 'j') then
-c
-c Continuing a jumped beam here
-c
- irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24)
-c
-c Set flag to watch for END of this forced beam, so can set flag rest(30) on
-c NEXT note as signal to start a new notes group there.
-c
- isbj2 = .true.
- go to 17
- else if (charq .eq. 'h') then
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2)
- go to 17
- else if (charq .eq. 'm') then
-c
-c Force multiplicity. Next input is digit
-c
- call getchar(lineq,iccount,charq)
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21)
- call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48)
- go to 17
- else if (charq .eq. ':') then
-c
-c Start auto forced beam pattern
-c
- autofbon = .true.
-c
-c When forced later beam ends, check whether tautofv <=0; if so set it.
-c
- tautofb = -itsofar(ivx)
- t1autofb = itsofar(ivx)
- go to 17
- else if (charq .ne. ' ') then
-c
-c Must be '+/-' for height or slope shift
-c
- nadj = nadj+1
-c
-c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- iadj = nint(fnum)
- if (charq .eq. '-') iadj = -iadj
- if (nadj .eq. 1) then
-c
-c This is a level shift. Note if 0 was entered, iadj = 30
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30)
- else if (nadj .eq. 2) then
-c
-c Must be a slope shift
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30)
- else
-c
-c Beam-thk fine tune
-c
- call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj)
- end if
- go to 17
- end if
- else if (charq .eq. ']') then
- if (autofbon .and. tautofb.lt.tol) then
- tautofb=itsofar(ivx)+tautofb
- end if
- call getchar(lineq,iccount,charq)
- if (index('j ',charq) .gt. 0) then
-c
-c Since ']' comes AFTER note, itsofar has been updated. Set ending signal.
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- if (charq .eq. 'j')
- * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23)
- if (isbj2) then
-c
-c This is the end of a fb segment of a jump beam. Set flag on NEXT note to
-c force start of new notes group, provided this is not last note in bar.
-c
- if (mod(itsofar(ivx),lenbar) .ne. 0)
- * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30)
- isbj2 = .false.
- end if
- else if (charq .eq. '[') then
-c
-c Multiplicity down-up signal
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20)
- else if (charq .eq. '-') then
-c
-c Set signals for gap in single-slope beam [...]-[...]
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20)
- nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21)
-c
-c Next two characters must be "[ ". Skip over them.
-c
- iccount = iccount+2
- end if
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)),
- * iornq(ivx,nnl(ivx)),lineq,iccount)
- else if (charq .eq. 'h') then
-c
-c Heading or height. For heading, only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "h" not at beginning of block'
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- ihdvrt = 0
- if (index('+-',durq) .gt. 0) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ihdvrt = fnum+.1
- if (durq .eq. '-') ihdvrt = -ihdvrt
- durq = charq
- end if
- if (durq .ne. ' ') then
-c
-c Height symbol. Read past (until next blank)
-c
-3 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 3
- else
-c
-c Set flag for header & read it in
-c
- ihdht = 16
- call getbuf(headrq)
- iccount = 128
- end if
- else if (charq .eq. 'L') then
-c
-c Linebreak, already handled in pmxa, but check for movement break
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fmovbrk)
- if (durq .eq. 'P') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- end if
- if (durq .eq. 'M') then
- movbrk = nint(fmovbrk)
- movgap = 0
- parmov = -1.
- call getchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Get vertical space (\internotes)
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- movgap = nint(fnum)
- go to 31
- else if (durq .eq. 'i') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,parmov)
- go to 31
- else if (durq .eq. 'c') then
- nobar1 = .true.
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
-c
-c "rename" can be set on or off.
-c
- call getchar(lineq,iccount,durq)
- rename = durq.eq.'+'
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iiorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iiorig in original list of instruments.
-c
- nvold = nv
- nv = 0
- rename = .true.
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
- ninow = ichar(durq)-48
- end if
- iiv = 0
- do 63 iinow = 1 , ninow
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow)
- else
- iiorig(iinow) = ichar(durq)-48
- end if
- nspern(iinow) = nsperi(iiorig(iinow))
- nv = nv+nspern(iinow)
- sepsymq(iiv+nspern(iinow)) = '&'
- if (nspern(iinow) .gt. 1) then
- do 64 iis = 1 , nspern(iinow)-1
- sepsymq(iiv+iis) = '|'
-64 continue
- end if
- iiv = iiv+nspern(iinow)
-63 continue
- if (islast) then
- if (ninow .lt. 10) then
- write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%'
- else
- write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%'
- end if
- end if
- if (nv.eq.1 .and. nvold.gt.1) then
- if (islast) write(11,'(a)')sq//'nostartrule'
- else if (nv.gt.1 .and. nvold.eq.1) then
- if (islast) write(11,'(a)')sq//'startrule'
- end if
- iiv = 0
- do 60 iinow = 1 , ninow
- do 61 iis = 1 , nspern(iinow)
- iiv = iiv+1
-c
-c May not really need to re-enter clefs, but it's easier to program since
-c clef names are not saved but are needed in newvoice to set ncmidcc.
-c
- call getchar(lineq,iccount,clefq(iiv))
- call newvoice(iiv,clefq(iiv),.true.)
- if (nspern(iinow) .eq. 1) then
- hdlndq = chax(48+numclef(clefq(iiv)))
- lclf = 1
- else if (iis .eq. 1) then
- hdlndq = '{'//chax(48+numclef(clefq(iiv)))
- lclf = 2
- else if (iis .lt. nspern(iinow)) then
- hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))
- lclf = lclf+1
- else
- hdlndq =
- * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}'
- lclf = lclf+2
- end if
-61 continue
-c
-c setstaffs & setclef go by instrument, not voice
-c
- if (islast) then
- if (iinow .lt. 10) then
- write(11,'(a)')sq//'setstaffs'
- * //chax(48+iinow)//chax(48+nspern(iinow))//'%'
- write(11,'(a)')sq//'setclef'//chax(48+iinow)
- * //hdlndq(1:lclf)//'%'
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinow,
- * '}'//chax(48+nspern(iinow))//'%'
- write(11,'(a9,i2,a)')sq//'setclef{',iinow,
- * '}'//hdlndq(1:lclf)//'%'
- end if
- end if
-60 continue
-c
-c Loop back up, this may not be last option in M. Note flow out if durq=' '
-c
- call getchar(lineq,iccount,durq)
- go to 31
- end if
-c
-c Write instrument names
-c
- if (.not.rename) then
- do 62 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%'
- else
- write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%'
- end if
- end if
-62 continue
- else
- do 65 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,'{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- end if
- end if
-65 continue
- rename = .false.
- end if
- end if
- else if (charq .eq.'|' ) then
-c
-c End of bar symbol. Check about end of bar hardspace.
-c
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by a bar line. Remove it from the hardspace
-c list, store with shifts instead, set special bit. Need to repeat this code
-c at '/'.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- else if (index('wS',charq) .gt. 0) then
-c
-c Width symbol or new nsyst. Read past (until blank)
-c
-4 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 4
- else if (charq .eq. 'l') then
-c
-c Lower string. Only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "l" not at beginning of block'
- call stop1()
- end if
-c
-c Set flag for lower string & read it in
-c
- lower = .true.
- call getbuf(lowerq)
- iccount = 128
- else if (charq .eq. 'm') then
-c
-c Meter change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "m" not at beginning of block'
- call stop1()
- end if
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenbar = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenbar = lenbar*2
- lenb1 = lenbar
- lenb0 = 0
- if (ismidi) call midievent('m',mtrnuml,mtrdenl)
- else if (charq .eq. 'C') then
-c
-c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music.
-c
- if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1
- tcc(iv,ncc(iv)) = itsofar(iv)
- isl = ibset(islur(iv,nnl(iv)+1),11)
- call getchar(lineq,iccount,durq)
-c
-c Store clef number, or 7 if clef number = 9 (French violin clef)
-c
- isl = ior(isl,ishft(min(numclef(durq),7),12))
- ncmidcc(iv,ncc(iv)) = ncmidf(durq)
-c
-c Set marker on note with lowest voice # starting at same time.
-c
- if (iv .eq. 1) then
- isl = ibset(isl,15)
- else
- do 13 iiv = 1 , iv
- nnliiv = nnl(iiv)
- if (iiv .eq. iv) nnliiv = nnliiv+1
- itother = 0
- do 14 iip = 1 , nnliiv
- if (itother .lt. itsofar(iv)) then
- itother = itother+nodur(iiv,iip)
- go to 14
- else if (itother .eq. itsofar(iv)) then
- islur(iiv,iip) = ibset(islur(iiv,iip),15)
- go to 15
- end if
-14 continue
-13 continue
-15 continue
- end if
-c
-c Need 'or' since may have set bit 15 in the above loop
-c
- islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1))
- else if (charq .eq. 'R') then
-c
-c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1)
-c
-10 call getchar(lineq,iccount,durq)
-c
-c Save designator in case it's a terminal Rr or Rd
-c
- if (durq .eq. 'l') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5)
- go to 10
- else if (index('rdDbz',durq) .gt. 0) then
- if (durq .eq. 'r') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
- else if (durq .eq. 'd') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8)
- else if (durq .eq. 'D') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26)
- else if (durq .eq. 'b') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25)
- else if (durq .eq. 'z') then
- iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29)
- end if
- rptprev = .true.
- rptfq1 = durq
- go to 10
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- nnnl = nnl(1)+1
- lvoltxt = 0
-11 call getchar(lineq,iccount,durq)
- if (durq.eq.'b' .or. durq .eq.'x') then
-c
-c End Volta, set bit9, and bit10 on if 'b' (end w/ box)
-c
- islur(1,nnnl) = ibset(islur(1,nnnl),9)
- if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10)
- go to 11
- else if (durq .ne. ' ') then
-c
-c Start volta; Get text
-c
- if (lvoltxt .eq. 0) then
-c
-c First character for text
-c
- lvoltxt = 1
- islur(1,nnnl) = ibset(islur(1,nnnl),7)
- nvolt = nvolt+1
- voltxtq(nvolt) = durq
- else
- voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq
- lvoltxt = lvoltxt+1
- end if
- go to 11
- end if
- else if (charq .eq. 'B') then
- bcspec = .not.bcspec
- else if (charq .eq. 'P') then
-c
-c Page numbers. Print stuff right now.
-c
- npg1 = 0
-c
-c Will use ltopnam to signal whether there's a centered heading
-c
- ltopnam = 0
- ipg1r = 0
-16 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48 .and. ichar(durq).le.57) then
- npg1 = npg1*10+ichar(durq)-48
- go to 16
- else if (durq .eq. 'l') then
- if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1
- go to 16
- else if (durq .eq. 'r') then
- if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1
- go to 16
- else if (durq .eq. 'c') then
-c
-c Top-centered name. Assume this is last option. Read the name.
-c May surround name in double quotes (to allow blanks).
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- ltopnam = lenstr(cheadq,60)
- else
- namstrt = iccount
- if (durq .eq. '"') then
-c
-c Using quote delimiters.
-c
- quoted = .true.
- namstrt = namstrt+1
- else
- quoted = .false.
- end if
- do 35 iccount = namstrt+1, 128
- if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or.
- * (.not.quoted .and. lineq(iccount:iccount) .eq. ' '))
- * go to 36
-c
-c On exit, iccount is OK, and name is in (namstrt:iccount-1)
-c
-35 continue
- print*,'Awww, cmon, should not be here.'
- call stop1()
-36 continue
- ltopnam = iccount-namstrt
- cheadq = lineq(namstrt:iccount-1)
- end if
- end if
-c
-c Done getting data, now assemble the command
-c
- if (npg1.eq.0) npg1=1
-c
-c 2/23/03 Don't use \atnextline if on first page and only one system
-c
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{'
- lhead = 27
-c else
-c hdlndq = sq//'toppageno{'
-c lhead = 11
-c end if
- if (npg1 .lt. 10) then
-c
-c Note we are overwriting the last "{"
-c
- write(hdlndq(lhead:lhead),'(i1)')npg1
- else if (npg1 .lt. 100) then
- lhead = lhead+3
- write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}'
- else
- lhead = lhead+4
- write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}'
- end if
- hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{'
- lhead = lhead+2
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- if (ltopnam .eq. 0) then
- if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%'
- else
- if (islast)
- * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%'
- end if
-c else
-c if (ltopnam .eq. 0) then
-c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%'
-c else
-c if (islast)
-c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%'
-c end if
-c end if
- else if (charq .eq. 'W') then
-c
-c Just eat the number that must follow, it was used in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else if (charq .eq. 'T') then
- headlog = .true.
- inhead = 0
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'i') then
- call getbuf(instrq)
-c
-c A kluge for parts from separate score file for later movements.
-c
- if (instrq(1:1) .eq. ' ') headlog = .false.
- cheadq = instrq
- else if (durq .eq. 't') then
- call getchar(lineq,iccount,durq)
-c
-c Optionally can include extra vertical \internotes above inbothd
-c
- if (index('-+0123456789',durq) .gt. 0) then
- ipm = 1
- if (index('+-',durq) .gt. 0) then
-c
-c Don't trust readnum to round this negative integer properly
-c
- iccount = iccount+1
- if (durq .eq. '-') ipm = -1
- end if
- call readnum(lineq,iccount,durq,fnum)
- inhead = ipm*nint(fnum)
- end if
- call getbuf(titleq)
- else
- call getbuf(compoq)
- end if
- inhead = inhead+inbothd
- iccount = 128
- else if (charq .eq. 'A') then
-c
-c Accidental handling etc.
-c
-27 call getchar(lineq,iccount,durq)
- if (durq .eq. 'r') then
- if (islast) then
- relacc = .true.
- write(11,'(a)')sq//'relativeaccid%'
- end if
- else if (durq .eq. 's') then
- bacfac = 1.e6
- else if (durq .eq. 'b') then
- if (islast) write(11,'(a)')sq//'bigaccid%'
- accfac = bacfac
- else if (durq .eq. 'a') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- else if (durq .eq. 'i') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,tintstf)
- if (.not.firstgulp) fintstf = tintstf
-c
-c Local corrections for first page were handled by pmxa
-c
- iccount = iccount-1
- else if (durq .eq. 'I') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- else if (durq .eq. 'd') then
- lowdot = .true.
- else if (durq .eq. 'o') then
- continue
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('-s',durq) .gt. 0) then
- fullsize(iiv) = 0.8
- else if (durq .eq. 't') then
- fullsize(iiv) = 0.64
- else
- fullsize(ivx) = 1.0
- end if
-50 continue
- else if (durq .eq. 'e') then
-c
-c Line-spacing equalization
-c
- equalize = .true.
-c
-c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so.
-c But it causes problems with some older scores and when excerpts are combined
-c with LaTeX. So as of 2.352 we write it here.
-c
- write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq
- * //'Interligne minus 99'//sq//'Interligne%'
- tempq = sepsymq(1)
- lentemp = 1
- do 51 iiv = 2 , nv-1
- tempq = tempq(1:lentemp)//sepsymq(iiv)
- lentemp = lentemp+1
-51 continue
- write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes'
- * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}'
- * //sq//'en}%'
- else if (durq .eq. 'v') then
-c
-c Toggle usevshrink
-c
- usevshrink = .not.usevshrink
- else if (durq .eq.'p') then
-c
-c Postscript slurs. fontslur is already false (set in g1etnote)
-c
- if (.not.WrotePsslurDefaults) then
-c
-c Set postscrirpt slur adjustment defaults
-c
- write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust'
- * //sq//'nohalfties'
- WrotePsslurDefaults = .true.
- end if
-52 continue
- call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l"
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c"
- if (durq .eq. '+') then
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Sluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Tieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'halfties'
- else
- SlurCurve = SlurCurve + 1
- if (SlurCurve .gt. 3.1) then
- call printl('WARNING!')
- call printl
- * ('Default slur curvature advanced past HH, resetting')
- SlurCurve = 3
- end if
- end if
- else
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Nosluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Notieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'nohalfties'
- else
- SlurCurve = SlurCurve - 1
- if (SlurCurve .lt. -1.1) then
- call printl('WARNING!')
- call printl(
- * 'Default slur curvature decremented below f, resetting')
- SlurCurve = -1
- end if
- end if
- end if
- go to 52 ! Check for another set of default changes
- else if (durq .eq. 'l') then
-c
-c Set optional linebreak ties
-c
- OptLineBreakTies = .true.
- go to 52
- else if (durq .eq. 'h') then
-c
-c Set flag to write header special on every page
-c
- HeaderSpecial = .true.
- go to 52
- else
- iccount = iccount-1
- end if
- else if (durq .eq. 'K') then
-c
-c Toggle keyboard rest placement flag
-c
- kbdrests = .not.kbdrests
- end if
-c if (durq .eq. 'N') then
- if (index('NR',durq) .gt. 0) then
-c
-c Override default part names for scor2prt, or normal include file.
-c Just bypass rest of input line
-c
- iccount = 128
- else if (durq .ne. ' ') then
- go to 27
- end if
- else if (charq .eq. 'K') then
- call getchar(lineq,iccount,durq)
- if (durq .ne. 'i') then
-c
-c Normal, full-score key change and/or transposition
-c
- num1 = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = num1*nint(fnum)
-c
-c On exit, durq='+','-'. But only need isig if after start, else done in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (num1 .eq. 0) then
-c
-c Key change, not transposition.
-c
- ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28)
- lastisig = isig
- isig = nint(fnum)
- if (durq .eq. '-') isig = -isig
- isig = isig+idsig
- if (ismidi) call midievent('k',isig,0)
- else
-c
-c num1 .ne. 0, so transposition, so must be at beginning. isig came with K...
-c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data
-c (signature before transposition). idsig must be added to future key changes.
-c
- jv = 0
- do while (jv .lt. nm)
- jv = jv+1
- iTransAmt(jv) = num1
- end do
- idsig = isig-isig0
- end if
- else
-c
-c Instrument specific transposition.
-
- call GetiTransInfo(.false.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
- end if
- else if (charq .eq. '/') then
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by end of block. Remove it from the hardspace
-c list, store with shifts instead, set special bit. This code also at '|'
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- call getchar(lineq,iccount,durq)
-c
-c Save ending note level:
-c
- if (ivx .le. nv) then
-c
-c This is the first line of music on this staff. If previous block had only 1
-c voice, save last pitch from line 1 of prev. block to line 2, in case a
-c 2nd line is started just below
-c
- if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1)
- was2(iv) = .false.
- ndlev(iv,1) = lastlev
- else
-c
-c This is the 2nd line of music on this staff.
-c
- was2(iv) = .true.
- ndlev(iv,2) = lastlev
- end if
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new line of music
-c
- if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New line of music is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c durq must be 2nd '/'. New line of music is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- nfb(ivx) = 0
- nudoff(ivx) = 0
- ndotmv(ivx) = 0
- do 24 j = 1 , 200
- irest(ivx,j) = 0
- islur(ivx,j) = 0
- nacc(ivx,j) = 0
- iornq(ivx,j) = 0
- ipl(ivx,j) = 0
- mult(ivx,j) = 0
-24 continue
-c
-c Go back and lower the rests in voice "a" that don't have over-ridden heights
-c
- do 26 j = 1 , nnl(iv)
- if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0)
- * nolev(iv,j) = -4
-26 continue
- end if
- end if
- iccount = 128
- else if (charq .eq. 'X') then
-c
-c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index,
-c which only happens for normal X at block start, and we took special measures to
-c keep group shifts for crossing block boundaries.
-c
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx,
- * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub)
- else if (charq .eq. 'I') then
-c
-c Midi controls.
-c
- call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,.false.)
- else if (charq .eq. 'M') then
-c
-c Macro action
-c
- call getchar(lineq,iccount,charq)
- if (index('RS',charq) .gt. 0) then
-c
-c Record or save a macro. Get the number of the macro.
-c
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call mrec1(lineq,iccount,ndxm)
- else
-c
-c Save (Record but don't activate)
-c
-5 call mrec1(lineq,iccount,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- iccount = 0
- go to 5
- end if
- iccount = iccount+ndxm+1
- end if
- else if (charq .eq. 'P') then
-c
-c Playback the macro
-c
- call getchar(lineq,iccount,charq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- ilmac = il1mac(macnum)
- mplay = .true.
- end if
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Check for start of forced beam on 2nd member of dotform=1 shortcut
-c
- if (fbon) then
- if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx))
- * t1fb(ivx,nfb(ivx)) =
- * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2
- end if
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- end if
- return
- end
- subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg,
- * ip,ivx,noxtup,notcrd,nole)
-c
-c iornq: Main note. Do not alter if chord note, except turn on bit 23
-c iornq0: Store iorni + bit 23, in case of repeated ornaments
-c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd.
-c noffseg: horiz. offset for segno
-c nole: level of note w/ orn, used to ID the note/orn if there's a level shift.
-c
-
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comcb/ nbc,ibcdata(36)
- character*1 charq,durq
- character*128 lineq
- logical ornrpt,negseg,noxtup,notcrd
-c
-c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U
-c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD
-c
- call getchar(lineq,iccount,charq)
- if (index('bc',charq) .gt. 0) then
-c
-c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc)
-c ivx(0-3,28), ip(4-12),
-c vshift (vshift+32 in bits 13-18),
-c hshift (nint(10*vshift)+128 in bits 19-26)
-c bit 27 = 0 if caesura, 1 if breath
-c bit 28: 5th bit of ivx
-c
- iornq = ibset(iornq,28)
- nbc = nbc+1
-c ibcdata(nbc) = ivx+16*ip
- ibcdata(nbc) = mod(ivx,16)+16*ip
- if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28)
- if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27)
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c We have a vertical shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),6,13,nint(32+fnum))
- if (index('+-',charq) .gt. 0) then
-c
-c Horizontal shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128)
- end if
- end if
- return
- end if
-c
-c Set signal on main note that some note at this time has ornament. ONLY used
-c in beamstrt to activate further tests for whether ihornb is needed.
-c
- iornq = ibset(iornq,23)
-c
-c Isolate 21 bits defining exisiting ornaments
-c
- if (notcrd) then
- iorni = iand(4194303,iornq)
- else
- iorni = iand(4194303,icrdorn(ncrd))
- end if
- korn = index('stmgx+Tupf._)e:XXX>^',charq)
- if (korn .ne. 15) iorni = ibset(iorni,korn)
-c
-c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later
-c as follows: korn=16-18 for sfn, and or 21 for bare ?.
-c When this if-block is done, korn will = bit# of actual ornament (unless "?").
-c
- if (korn .eq. 15) then
-c
-cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq
-c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq
-c
-c iorni = ior(iorni,iand(iornq0,1638383))
- iorni = ior(iorni,iand(iornq0,3735535))
- ornrpt = .false.
- call getchar(lineq,iccount,durq)
-c
-c durq will be ' '
-c
- else if (korn .eq. 14) then
-c
-c Editorial accidental
-c
- call getchar(lineq,iccount,durq)
-c korn = 15+index('sfn',durq)
- korn = 15+index('sfn?',durq)
- if (korn .eq. 19) korn=21
- iorni = ibset(ibclr(iorni,14),korn)
- call getchar(lineq,iccount,durq)
- if (durq .eq. '?') then
-c
-c This is "oe[s|f|n]?". Set 21st bit also.
-c
- iorni = ibset(iorni,21)
- korn = korn+6
- call getchar(lineq,iccount,durq)
- end if
-c iorni = ibset(ibclr(iorni,14),korn)
- else if (korn.eq.4 .and. noxtup) then
-c
-c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points
-c
- noffseg = 0
- negseg = .false.
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Segno shift is specified
-c
- if (durq .eq. '-') then
- negseg = .true.
- call getchar(lineq,iccount,durq)
- end if
- call readnum(lineq,iccount,durq,fnum)
- noffseg = int(fnum)
- if (negseg) noffseg = -noffseg
- end if
- else if (korn .eq. 7) then
-c
-c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr"
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = ip
- xnsktr(ntrill) = 1.
- call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Convert to new internal symbol for non-'"tr" trill
-c
- korn = 15
- iorni = ibset(ibclr(iorni,7),15)
- call getchar(lineq,iccount,durq)
- end if
- if (index('0123456789.',durq) .gt. 0) then
-c
-c We have a number for the length
-c
- call readnum(lineq,iccount,durq,xnsktr(ntrill))
- end if
- else if (korn.eq.10 .and. noxtup) then
-c
-c Fermata
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'd') then
- korn = 14
- iorni = ibset(ibclr(iorni,10),14)
- call getchar(lineq,iccount,durq)
- end if
- else
- call getchar(lineq,iccount,durq)
- end if
- if (index('+- :',durq) .eq. 0) then
- print*,'Unexpected character at end of ornament: ',durq
- call stop1()
- end if
- if (index('+-',durq) .gt. 0) then
-c
-c Shift ornament up or down
-c
- nudorn = nudorn+1
-c
-c Set bit 25 in iorni as a signal. This may not really be necessary.
-c
- iorni = ibset(iorni,25)
-c
-c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev,
-c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present
-c
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iofforn = nint(xofforn*fnum)
- kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12)
- * +ishft(korn,19)+ishft(iofforn+32,25)
- ivxudorn(nudorn) = ivx
- if (index('+-',durq) .gt. 0) then
-c
-c Horizontal shift
-c
- kudorn(nudorn) = ibset(kudorn(nudorn),31)
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- ornhshft(nudorn) = nint(xofforn*fnum)
- end if
- else if (durq .eq. ':') then
-c
-c Turn on repeated ornaments
-c
- ornrpt = .true.
-c
-c Save the ornament value just set
-c
- iornq0 = iorni
- end if
- if (notcrd) then
- iornq = ior(iornq,iorni)
- else
- icrdorn(ncrd) = ior(icrdorn(ncrd),iorni)
- end if
- return
- end
- subroutine getpmxmod(global,includeq)
-c
-c If global=.true., checks for environment variable with path to pmx.mod.
-c Then, if variable exists and points to pmx.mod, insert lines from
-c pmx.mod into buffer
-c If global=.false., checks for existence of includeq and uses it.
-c
-c lenbuf0 = total length of bufq on entry
-c lbuf(i) = length of line (i)
-c nlbuf = number of lines stored in bufq
-c ilbuf = index of first line after setup stuff (on entry). In general, index of
-c next line to be sucked from buffer.
-c ilbufmod = counter for lines in pmx.mod as they are grabbed.
-c Starts at ilbuf. Points to position of next line after
-c pmx.mod stuff in bufq on exiting loop 1
-c ilbuff = transient counter for shifting operations
-c ipbuf = on entry, points to last character in setup stuff. In general, points
-c to last character of most recent line sucked from buffer.
-c ipbufmod = points to last character of most recent inserted line
-c from pmx.mod
-c
- parameter (maxblks=4000,nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*(*)includeq
- character*80 pmxmoddirq
- character*128 lnholdq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical fexist,global
- line1pmxmod = ilbuf
- if (.not.global) then
- inquire(file=includeq,EXIST=fexist)
-c
-c Transfer includeq to temporary char variable with known length
-c
- pmxmoddirq = includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- print*
- write(15,'()')
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', checking further.')
-c
-c File named includeq doesn't not exist. Get directory from PMXMODDIR and
-c see if it's there
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq. gt. 0) then
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- else
- call printl(
- * 'No other directory defined by PMXMODDIR, stopping')
- call stop1()
- end if
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', stopping.')
- call stop1()
- end if
- end if
- call printl('Opening normal include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq)
- else
-c
-c Check for existence of pmx.mod
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq .eq. 0) return
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod'
- lpmxmoddirq = lpmxmoddirq+7
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) return
- call printl('Opening global include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq(1:lpmxmoddirq))
- end if
- call printl('Adding include data')
-c
-c Read lines in from pmx.mod one at a time
-c
- ipbufmod = ipbuf
- lenbufmod = lenbuf0
- do 1 ilbufmod = ilbuf , maxblks
- read(18,'(a)',end=3)lnholdq
-c
-c A line was read. Slide all existing lengths from here forward ahead by 1
-c
- do 2 ilbuff = nlbuf , ilbufmod , -1
- lbuf(ilbuff+1) = lbuf(ilbuff)
-2 continue
-c
-c Get length of line from include file
-c
- lenmodline = lenstr(lnholdq,128)
- if (lenmodline .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lenmodline = 1
- lnholdq = ' '
- end if
- lbuf(ilbufmod) = lenmodline
- call printl(lnholdq(1:lenmodline))
-c
-c Insert new stuff into bufq
-c
- bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)//
- * bufq(ipbufmod+1:lenbufmod)
-c
-c Update internal parameters
-c
- ipbufmod = ipbufmod+lbuf(ilbufmod)
- lenbufmod = lenbufmod+lbuf(ilbufmod)
- nlbuf = nlbuf+1
-1 continue
-3 continue
- call printl('Closing '//pmxmoddirq(1:lpmxmoddirq))
- close(18)
- linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf
- lenbuf0 = lenbufmod
-c
-c Fix Andre's error reporting problem 101211 leading to log(neg#) due
-c to nline being 2 bigger than it should be
-c
- nline=nline-2
-c
- return
- end
- subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0,
- * inameq,clefq,sepsymq,pathnameq,lpath,isig0)
- parameter (nm=24)
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*1 clefq(nm),sepsymq(nm)
- character*40 pathnameq
- character*79 inameq(nm)
- character*128 lineq
- logical istype0,newway,rename
-c
-c Get the first line
-c
- iccount = 0
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 9
- istype0 = lineq(1:3).eq.'---'
- if (istype0) then
-c
-c Have TeX input until next line that starts with '---'. Save in scratch.
-c
- open(17,status='SCRATCH')
-3 call getbuf(lineq)
- if (lineq(1:3) .ne. '---') then
- write(17,'(a)')lineq
- go to 3
- end if
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq is first line w/ numerical setup data.
-c
- nv = nint(readin(lineq,iccount,nline))
- noinst = nint(readin(lineq,iccount,nline))
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 2 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
-c
-c Read in nvi for each instrument
-c
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
- iiorig(iinst) = iinst
- nspern(iinst) = nsperi(iinst)
-2 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge to make mtrdenl work
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- xmtrnum0 = readin(lineq,iccount,nline)
-c
-c Original key sig (before any trnasposition) in next position. Transposed
-c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key
-c changes if transposed.
-c
- isig0 = nint(readin(lineq,iccount,nline))
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musicsize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , noinst
-5 call getbuf(inameq(i))
- if (inameq(i)(1:1) .eq. '%') go to 5
-4 continue
-c
-c Mext non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 6
- iv = 0
- nvsofar = 0
- do 1 jinst = 1 , noinst
- nvsofar = nvsofar+nsperi(jinst)
- do 10 ivi = 1 , nsperi(jinst)
- iv = iv+1
- clefq(iv) = lineq(iv:iv)
- if (iv .eq. nvsofar) then
- sepsymq(iv) = '&'
- else
- sepsymq(iv) = '|'
- end if
-10 continue
-1 continue
-c
-c Mext non-comment line has path name
-c
-8 call getbuf(pathnameq)
- if (pathnameq(1:1) .eq. '%') go to 8
- lpath = index(pathnameq,' ')-1
- return
- end
- function getsquez(n,ntot,space,tnote,to)
- real*4 tnote(600),to(600)
- common /comtol/ tol
-c
-c Get the squez factor by checking space against tgovern=minimum duration
-c of all notes sounding at time of n-th note in the list.
-c The starting time of base increment is to(n) and ending time is to(n)+space
-c Sounding notes are those that start at or before to(n) .and. end at or
-c after tend=to(n)+space
-c Since notes are ordered by increasing start times, as soon as we find one
-c that starts too late, we are done checking.
-c
- tgovern = 1000.
- tend = to(n)+space
- do 1 in = 1 , ntot
-c
-c Since to() is ordered by start times, exit loop after first note that
-c starts later than note of interest.
-c
-
- if (to(in) .gt. to(n)+tol) go to 2
- if (to(in)+tnote(in) .gt. tend-tol) then
-c
-c If here, this note overlaps and must be tested.
-c
- tgovern = min(tgovern,tnote(in))
- end if
-1 continue
-2 continue
- getsquez = space/tgovern
- return
- end
- subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx,
- * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub)
- parameter(nm=24)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c Since during getnote phase time is integer itsofar, which is not updated
-c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if
-c not in xtup.
-c
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical shifton,colon,ess,number
- character*128 lineq
- character*1 charq,durq,dotq
- colon = .false.
- ess = .false.
- number = .false.
- nextbl = iccount+index(lineq(iccount:128),' ')-1
- if (index(lineq(iccount:nextbl),'P') .gt. 0) then
-c
-c "Parts only", ignore entire symbol
-c
- iccount = nextbl
- return
- end if
-1 call getchar(lineq,iccount,charq)
- if (charq.eq.'B') then
-c
-c "Both parts and score," ignore character
-c
- go to 1
- else if (charq .eq. ':') then
- colon = .true.
- go to 1
- else if (charq .eq. 'S') then
- ess = .true.
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (charq.eq.'-') iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum = -fnum
- if (durq .ne. 'p') then
- fnum = fnum*wheadpt
- iccount = iccount-1
- end if
- go to 1
- end if
-c
-c charq must be blank, so done parsing
-c
- if (.not.ess .and. .not.colon) then
-c
-c Ordinary hardspace. Goes before next note.
-c (Later, at "|" or "/", check for presence and switch to udoff if there!)
-c
- nudsp = nudsp+1
- iornq1 = ibset(iornq1,26)
- udsp(nudsp) = fnum
- tudsp(nudsp) = itsofar
- if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp)
-c * +float(itup-1)/ntup*ifnodur(nnodur,dotq)
- * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq)
- else if (.not.number) then
-c
-c Must be "X:" End a group offset.
-c
- irest = ibset(irest,17)
- shifton = .false.
- return
- else
-c
-c Only other possibility is start offset, "S" for single, ':' for multiple
-c
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = fnum
- if (ess) then
- irest1 = ibset(irest1,15)
- else
- irest1 = ibset(irest1,16)
- shifton = .true.
- end if
- end if
- return
- end
- function i1fnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- i1fnodur=1
- else if (idur .eq. 3) then
- i1fnodur=2
- else if (idur .eq. 1) then
- i1fnodur=4
- else if (idur .eq. 8) then
- i1fnodur=8
- else if (idur .eq. 4) then
- i1fnodur=16
- else if (idur .eq. 2) then
- i1fnodur=32
- else if (idur .eq. 0) then
- i1fnodur=64
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- i1fnodur=4
- else if (idur .eq. 9) then
- i1fnodur = 128
- else
- print*
- print*,'You entered an invalid note-length value:',idur
- call stop1()
- end if
- if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2
- return
- end
-c integer*4 function longi(ishort)
-c integer*2 ishort
-c longi = ishort
-c return
-c end
- function iashft(nacc)
- integer*4 ias(6)
- data ias /-1,1,0,0,-2,2/
- iashft = ias(nacc)
- return
- end
- function ifnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- ifnodur=1
- else if (idur .eq. 3)then
- ifnodur=2
- else if(idur .eq. 1) then
- ifnodur=4
- else if(idur .eq. 8) then
- ifnodur=8
- else if(idur .eq. 4) then
- ifnodur=16
- else if(idur .eq. 2) then
- ifnodur=32
- else if(idur .eq. 0) then
- ifnodur=64
- else if(idur .eq. 9) then
- ifnodur=128
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- ifnodur=4
- else
- print*,'You entered an invalid note value'
- stop
- end if
- if (dotq .eq. 'd') ifnodur = ifnodur*3/2
- return
- end
- function ifnolev(noq,oct,ntrans)
- character*1 noq
- integer oct
- ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans
- return
- end
-c subroutine report(nsdat,isdat1,isdat2)
-c integer*4 isdat1(202),isdat2(202)
-c write(*,'(a)')
-c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd'
-c do 1 isdat = 1 , nsdat
-c isdata = isdat1(isdat)
-c ionoff = igetbits(isdata,1,11)
-cc iv = iand(7,isdata)
-c iv = igetbits(isdata,5,13)
-c kv = igetbits(isdata,1,12)+1
-c ip = igetbits(isdata,8,3)
-c idcode = igetbits(isdata,7,19)
-c iud1 = igetbits(isdata,1,26)
-c iud2 = igetbits(isdata,1,27)
-c ndxslur = igetbits(isdata,4,28)
-c isdatb = isdat2(isdat)
-c ivo = igetbits(isdatb,6,6)-32
-c iho = igetbits(isdatb,7,12)-64
-c lev = igetbits(isdatb,7,19)
-c icrd = igetbits(isdatb,1,0)
-c lhd = igetbits(isdatb,1,1)
-c irhd = igetbits(isdatb,7,2)
-c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur,
-c * ivo,iho,lev,icrd,lhd,irhd
-c1 continue
-c print*
-c return
-c end
- function igetbits(isdata,iwidbit,ishift)
-c
-c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and
-c then added to ioff
-c
- igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift))
- return
- end
- function igetvarlen(mmidi,icm,imidi,nbytes)
-c
-c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes.
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi(0:nm,mv)
- igetvarlen = 0
- do 1 nbytes = 1 , 4
- igetvarlen = 128*igetvarlen
- * +iand(127,mmidi(icm,imidi+nbytes))
-c * +iand(127,longi(mmidi(icm,imidi+nbytes)))
- if (.not.btest(mmidi(icm,imidi+nbytes),7)) return
-c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return
-1 continue
- print*,'Messup in igetvarlen'
- call stop1()
- end
- logical function isdotted(nodur,ivx,ip)
- parameter (nm=24)
-c
-c Function returns true if note is dotted or double-dotted.
-c Return false for any xtuplet.
-c
- common /comtol/ tol
- integer*4 nodur(nm,200)
- if (nodur(ivx,ip) .eq. 0) then
- isdotted = .false.
- return
- else if (ip .gt. 1) then
- if (nodur(ivx,ip-1) .eq. 0) then
- isdotted = .false.
- return
- end if
- end if
-c
-c Ruled out all xtups, so is dotted or double-dotted if not a power of 2.
-c
- isdotted =
- * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol
- return
- end
- function isetvarlen(idur,nbytes)
- isetvarlen = 0
- itemp = idur
- do 1 nbytes = 1 , 4
- isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1)
- itemp = ishft(itemp,-7)
- if (itemp .gt. 0) then
- isetvarlen = isetvarlen+2**(8*nbytes+7)
- else
- return
- end if
-1 continue
- print*,'Problem in function isetvarlen'
- call stop1()
- end
- subroutine istring(i,string,len)
-c
-c Returns string with integer only if length is 1, otherwise enclosed in
-c brackets.
-c
- character*(*) string
- if (i .ne. 0) then
- len = alog10(abs(i)*1.0001)+1
- if (i .lt. 0) len = len+1
- else
- string = '0'
- len = 1
- return
- end if
- if (len .eq. 1) then
- string = char(48+i)
- else
- string = '{'
- write(string(2:1+len),'(i'//char(48+len)//')')i
- string = string(1:len+1)//'}'
- len = len+2
- end if
- return
- end
- function lenstr(string,n)
- character*(*) string
- do 1 lenstr = n , 1 , -1
- if (string(lenstr:lenstr) .ne. ' ') return
-1 continue
- lenstr = 0
- return
- end
- function levrn(nolev,irest,iud,ncm,mult)
-c
-c Used for placing numbers in xtups. Returns note level if not a rest,
-c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm.
-c
- logical btest
- if (.not.btest(irest,0)) then
- levrn = nolev
- else
-c
-c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default.
-c
- if (mult .gt. 0) then
- if (mult .eq. 2) then
- ioff = -1+2*iud
- else if (mult .ne. 4) then
- ioff = iud*mult
- else
- ioff = 1+4*iud
- end if
- else
-c
-c May need to futz with this later for non-beamed xtups (quarter, half rests)
-c
- ioff = iud*2
- end if
- levrn = mod(nolev+20,100)-20+ncm+ioff
- endif
- return
- end
- function lfmt1(x)
-c
-c Computes total length of an "f" format with one decimal place.
-c First round to nearest 0.1
-c
- if (abs(x) .lt. .001) then
- lfmt1 = 2
- else
- y = sign(.1*int(10*abs(x)+.5),x)
- lfmt1 = int(log10(1000*abs(y)+.001))
- if (y .lt. 0) lfmt1 = lfmt1+1
- end if
- return
- end
- subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- parameter (nm=24)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie
- character*1 udq,chax,sepsymq(nm)
- character*8 noteq
- character*128 notexq
-c
-c This is called twice from pmxb after having input an entire block, before
-c making a bar that starts a new system. So nsdat reflects all slur starts
-c and stops in new block, while listslur, which is only set when bars are
-c made, reflects only open slurs from the old block. So we must check
-c listslur to find open ties, not all nsdat.
-c First of two calls (ispstie=.false. on entry) terminates tie at end of line.
-c Second (ispstie=.true. on entry) restarts tie at start of new line. Only
-c need data from original tie-start for both of these. Tie/slur data from
-c closing of full tie are not used except for shape alterations.
-c
-c do 1 ndx = 0 , 11
- do 1 ndx = 0 , 23
- if (btest(listslur,ndx)) then
-c
-c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie
-c
- do 2 isdat = 1 , nsdat
-c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index
- if (igetbits(isdat1(isdat),4,28)
- * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index
- if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop
- if (btest(isdat2(isdat),3)) go to 3 ! "st"
- idcode = igetbits(isdat1(isdat),7,19)
- if (idcode.eq.1) go to 3 ! "t"
- tie = .false.
- go to 5
-2 continue
- end if
- go to 1
-3 continue
- tie = .true.
-5 continue
-c
-c A slur or tie is open, with index ndx
-c
- iv = igetbits(isdat1(isdat),5,13)
- kv = igetbits(isdat1(isdat),1,12)+1
- udq = 'd'
- if (btest(isdat1(isdat),27)) udq='u'
- notexq = chax(92)//'znotes'
- lnote = 7
- do 4 iiv = 1 , iv-1
- notexq = notexq(1:lnote)//sepsymq(iiv)
- lnote = lnote+1
-4 continue
- if (kv .eq. 2) then
- notexq = notexq(1:lnote)//chax(92)//'nextvoice'
- lnote = lnote+10
- end if
-c
-c Compute horiz and vert offsets
-c
-c nolev = igetbits(isdat2(isdat),7,19)
- islhgt = igetbits(isdat3(isdat),8,14)
- ilb12 = 0
- if (ispstie) ilb12 = 1
- ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32
- if (ivoff .eq. -32) ivoff = 0
-C nolev = nolev+ivoff
- islhgt = islhgt+ivoff
- ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff
- if (ihoff .eq. -64) ihoff = 0
-c
-c Add starting stuff for command
-c
- if (.not.ispstie) then ! End 1st segment
- notexq = notexq(1:lnote)//chax(92)//'roffset{'
- lnote = lnote+9
-c hoff = ihoff*.1-.5
-c hoff = ihoff*.1-.8
- hoff = ihoff*.1-.4
- if (hoff .lt. 0) then
- hoff = -hoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(hoff,notexq,lnote)
- notexq = notexq(1:lnote)//'}{'
- lnote = lnote+2
- else
- notexq = notexq(1:lnote)//chax(92)//'off{-'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+21
-c
-c 091025 add dotting for 2nd segment if needed
-c
- if (btest(isdat2(isdat),4)) then
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
- end if
- if (ispstie .and. tie) then
- notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq
- lnote = lnote+10
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Curvature tweak on termination of 1st seg
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 4 h
-c 5 H
-c 6 HH
-c
- notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid)
- lnote = lnote+9
-c
-c Zero out the flag in case there's a different curv on term of 2nd,
-c
- isdat3(isdat) = ibclr(isdat3(isdat),0)
- end if
-c
-c Add the command name
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'is'//udq
- lnote = lnote+4
- else if (tie) then
- notexq = notexq(1:lnote)//chax(92)//'ttie'
- lnote = lnote+5
- else
- notexq = notexq(1:lnote)//chax(92)//'tslur'
- lnote = lnote+6
- end if
-c
-c Add index
-c
-c if (11-ndx .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndx)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}'
-c lnote = lnote+4
-c end if
- if (23-ndx .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndx)
- lnote = lnote+1
- else if (23-ndx .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}'
- lnote = lnote+4
- end if
- if (ispstie .or. .not.tie) then
-c
-c Add note name for slur height
-c
- noctup = 0
- ncm = igetbits(isdat3(isdat),8,22)
- if (ncm .eq. 23) noctup = -2
-c call notefq(noteq,lnoten,nolev,ncm)
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}'
- lnote = lnote+1+lnoten+1
- end if
- if (ispstie) then
-c
-c Horizontal shift start of new thing
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
-c ihoff = ihoff-13
- if (tie) then
- ihoff = ihoff-12
- else
- ihoff = ihoff-7
- end if
- if (ihoff .lt. 0) then
- ihoff = -ihoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(ihoff*.1,notexq,lnote)
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Add closing stuff
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'off{'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+20
- else
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//chax(92)//'en%'
- lnote = lnote+4
- write(11,'(a)')notexq(1:lnote)
-1 continue
- ispstie = .not.ispstie
- return
- end
- subroutine littex(islur,nnl,iv,topmods,lineq,iccount)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- integer islur(nm,200)
- logical topmods
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,merge
- character*128 lineq,litq
- character*20 voltxtq
- character*1 durq,chax
- merge = .false.
- if (nlit .gt. 0) then
- merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit)
- end if
- nlit = nlit+1
- ivlit(nlit) = iv
- iplit(nlit) = nnl
- itype = 1
-17 call getchar(lineq,iccount,durq)
- if (durq .eq. chax(92)) then
- itype=itype+1
- go to 17
- end if
- litq(nlit) = chax(92)//durq
- lenlit(nlit) = 2
-18 call getchar(lineq,iccount,durq)
- if (durq.eq.chax(92)) then
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Starting a new tex command within the string
-c
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq
- lenlit(nlit) = lenlit(nlit)+2
- go to 18
- end if
- else
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq
- lenlit(nlit) = lenlit(nlit)+1
- go to 18
- end if
-c
-c If here, just read backslash-blank so string is done
-c
- if (itype .eq. 1) then
- islur(iv,nnl) = ibset(islur(iv,nnl),16)
- if (merge) then
-c
-c There are 2 separate strings on the same note, so merge them.
-c
- nlit = nlit-1
- litq(nlit) = litq(nlit)(1:lenlit(nlit))
- * //litq(nlit+1)(1:lenlit(nlit+1))
- lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1)
- if (lenlit(nlit) .gt. 128) then
- print*
- print*,
- * 'Merged type-1 TeX strings longer than 128 characters'
- write(15,'(/,a)')
- * 'Merged type-1 TeX strings longer than 128 characters'
- call stop1()
- end if
- end if
- else
- if (itype .eq. 3) then
-c
-c Write the string NOW
-c
- if (islast)
- * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- else
-c
-c Must go at top
-c
- if (.not.topmods) then
- topmods = .true.
- open(16,status='SCRATCH')
- end if
-c
-c Must write '%' here rather than later, in case string ends with blank.
-c
- write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- end if
- nlit = nlit-1
- end if
- return
- end
- function llen(strq,n)
- character*129 strq
- do 1 llen = n , 0 , -1
- if (strq(llen:llen) .ne. ' ') return
-1 continue
- end
- function log2(n)
-c
-c 5/25/08 Modify to allow more slurs
-c
-c log2 = alog(1.*n)/0.6931472+.0001
-c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0
- log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0
- return
- end
- subroutine logbeam(numnew,nip1,nip2)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq,ulfq,ulfbq
- logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest,
- * autofbon
- ibm1(ivx,numnew) = nip1
- ibm2(ivx,numnew) = nip2
- numnow = numnew
- if (numnew .gt. 1) then
-c
-c If it starts before any others, must put it in order
-c
- do 11 ib = numnew-1 , 1 , -1
- if (ibm1(ivx,ib) .lt. nip1) go to 12
- ibm1(ivx,ib+1) = ibm1(ivx,ib)
- ibm2(ivx,ib+1) = ibm2(ivx,ib)
- ulq(ivx,ib+1) = ulq(ivx,ib)
- ibm1(ivx,ib) = nip1
- ibm2(ivx,ib) = nip2
- numnow = ib
-11 continue
-12 continue
- end if
- sum = 0.
-c
-c Beam has non-xtup within
-c
- nrests = 0
- isxtup = .false.
- do 9 iip = nip1 , nip2
- if (btest(islur(ivx,nip1),21)) then
-c
-c Forced multiplicity
-c
-c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22)
- call setbits(mult(ivx,iip),4,0,
- * igetbits(islur(ivx,nip1),3,22)+8)
- else if (.not.isxtup) then
- if (nodur(ivx,iip) .gt. 0) then
-c mult(ivx,iip) = 4-log2(nodur(ivx,iip))
- call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8)
- else
-c
-c Start xtup within forced beam
-c
- isxtup = .true.
- iip1 = iip
- end if
- else if (isxtup .and. nodur(ivx,iip).gt.0) then
-c
-c End of xtup within forced beam. Must count doubled notes
-c
- ndoub = 0
- do 1 iiip = iip1 , iip
- if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1
-1 continue
- multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)-
- * alog(nodur(ivx,iip)/2.))/0.69315)-10
- do 74 iiip = iip1 , iip
-c mult(ivx,iiip) = multx
- call setbits(mult(ivx,iiip),4,0,multx+8)
-c
-c Note the following still works after making mult only the 1st 4 bits.
-c
- if (btest(nacc(ivx,iiip),18))
- * mult(ivx,iiip) = mult(ivx,iiip)-1
- if (btest(nacc(ivx,iiip),19)) then
- mult(ivx,iiip) = mult(ivx,iiip)+1
- else if (iiip .gt. 1) then
- if (btest(nacc(ivx,iiip-1),19))
- * mult(ivx,iiip) = mult(ivx,iiip)+1
- end if
-74 continue
- isxtup = .false.
- end if
- if (btest(irest(ivx,iip),0)) then
- nrests = nrests+1
- else
- sum = sum+nolev(ivx,iip)
- end if
-9 continue
-c
-c Set beam up-down-ness
-c
- if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then
- if (ulfbq(ivx,ifb) .eq. 'f') then
-c
-c Get default, then trade "l" and "u"
-c
- ulq(ivx,numnow) = char(225-ichar(
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))))
- else
- ulq(ivx,ifb) = ulfbq(ivx,ifb)
- end if
-c
-c This probably works only because forced beams are done first, so they
-c don't have to be re-sorted within each voice. ????
-c
- else if (nvmx(iv) .eq. 2) then
-c
-c Multi-voice per staff
-c
- if (ivx .le. nv) then
- ulq(ivx,numnow) = 'l'
- else
- ulq(ivx,numnow) = 'u'
- end if
- else
-c
-c Defaults
-c
- ulq(ivx,numnow) =
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))
- end if
- return
- end
- subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=4000)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- logical mrecord,mplay,endmac
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lbuf(1) = lbuf(1)
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then
- call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1,
- * 'Improper macro termination!')
- call stop1()
- end if
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- parameter (nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst
- common /comeskz2/ eskz2(nm,200)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm),
- * numbms(nm),mapfb(16)
- real*4 xit(nm),t1xtup(20),tstart(80),squez(80)
- character*1 ulfbq
- character*79 inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 headrq,lowerq
- logical cwrferm
- common /comcwrf/ cwrferm(nm)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical lower,cwrest(nm),vxtup,flgndb,btest,upslur,
- * infbmx(nm),lowdot,inxtup(nm),drawbm
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Above are factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comtol/ tol
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur,
- * WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comntot/ ntot
- if (ismidi) then
-c
-c Initialize for this bar the accidental counter for the midi file.
-c naccim(icm) = # of accidentals from earlier in the bar
-c
- do 45 iv = 1 , nv
- do 45 kv = 1 , nvmx(iv)
- naccim(midchan(iv,kv)) = 0
-45 continue
- end if
-c
-c Time from start of gulp to end of bar, used with forced beams
-c
- tglp2 = lenb0+ibar*lenb1
- if (lenb0 .gt. 0) tglp2 = tglp2-lenb1
- tglp1 = tglp2-lenbar
-c
-c infbmx will only be true if in xtup that is NOT in explicit forced beam.
-c
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrest(ivx) = .false.
- infbmx(ivx) = .false.
- inxtup(ivx) = .false.
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv). The loop to 4
-c ONLY initializes each voice.
-c
- in = 1
- nxtup = 0
- narp = 0
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrferm(ivx) = .false.
- cnn(ivx) = 1
- ivxo(in) = ivx
- ipo(in) = cnn(ivx)
- tnote(in) = fnote(nodur,ivx,1,nacc)
- to(in) = 0.
- xit(ivx) = tnote(in)
-c
-c Note that xit(ivx) is to END of note in voice, but it1xtup is start time.
-c
- if (nodur(ivx,ipo(in)) .eq. 0) then
-c
-c First note of xtuplet at start of bar in voice ivx.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = 0.
-c
-c Xtup at start of bar. If no explicit forced beam, start one, set
-c signal infbmx, and save number ifbnow for use at termination.
-c
- if (nfb(ivx) .gt. 0) then
- do 60 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c No explicit fb here; so exit loop and insert one.
-c
- go to 61
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit fb here; must NOT insert one
-c
- go to 62
- end if
-60 continue
- end if
-61 continue
-c
-c If here, xtup isn't in explicit fb, so must insert one
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+
- * tglp1,t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-62 continue
- if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000.
- in = in+1
-4 continue
-c
-c Build the list: This is a manual loop starting at 5
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iiv = 1 , nv
- do 6 kv = 1 , nvmx(iiv)
- iivx = ivmx(iiv,kv)
- tminn = min(tmin,xit(iivx))
- if(tminn .lt. tmin-tol) then
- tmin = tminn
- ivx = iivx
- end if
-6 continue
- if (abs(tmin-1000.) .lt. tol) go to 7
- ivxo(in) = ivx
- cnn(ivx) = cnn(ivx)+1
- ipo(in) = cnn(ivx)
- to(in) = tmin
-c
-c Check if this voice is done
-c
- tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc)
- if (cnn(ivx) .eq. nn(ivx)) then
- xit(ivx) = 1000.
- else
- xit(ivx) = xit(ivx)+tnote(in)
- end if
-c
-c Flag xtups
-c
- if (nodur(ivx,cnn(ivx)) .eq. 0) then
- if (.not.inxtup(ivx)) then
-c
-c First note of xtup, not at start of bar.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = xit(ivx)-tnote(in)
-c
-c (Note: can't be on last note in voice, so xit(ivx) <> 1000)
-c Put xtuplet in a forced beam if not already in forced beam
-c
- if (nfb(ivx) .gt. 0) then
- do 70 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c NO explicit bm; put one in
-c
- go to 71
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit bm. Don't put one
-c
- go to 72
- end if
-70 continue
- end if
-71 continue
-c
-c If here, no explicit bm, so put one in
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+tglp1,
- * t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-72 continue
- else if (inxtup(ivx)) then
-c
-c This test is sufficient because already know nodur>0
-c
- inxtup(ivx) = .false.
- if (infbmx(ivx)) then
-c
-c Xtup is in auto-forced beam, so end it
-c
- t2fb(ivx,ifbnow(ivx)) =
- * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1
- infbmx(ivx) = .false.
- end if
- end if
- if (btest(irest(ivxo(in),ipo(in)),24) .or.
- * btest(irest(ivxo(in),ipo(in)),30)) then
-c
-c For staff jumped beam, flag the first note (lowest voice) at same time.
-c Later will start new notes group here.
-c
- inj = in
- if (ivxo(in) .gt. 1) then
- do 40 iin = in-1 , 1 , -1
- if (to(iin)+tol .lt. to(in)) go to 41
- if (abs(to(iin)-to(in)) .lt. tol) then
- inj = iin
- go to 40
- end if
-40 continue
- end if
-41 continue
- irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29)
- end if
- in = in+1
- go to 5
-7 continue
- ntot = in-1
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = tnote(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(a)')' Greetings from PMXB'
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot)
-c
-c Done w/ list. Loop for parsing into note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c A manual loop to set space(ib) and istop(ib)
-c
-9 continue
-
- ivx = ivxo(min(in+1,ntot))
- ip = ipo(min(in+1,ntot))
- isl = islur(ivx,ip)
- if (in.eq.ntot .or. ((ivx.eq.1 .and.
- * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28)
-c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then
-c Bits 1-13: stmgx+Tupf._)
-c 14: Down fermata, was F
-c 15: Trill w/o "tr", was U
- * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) )
-c
-c Checking for start of 2nd part of jumped beam
-c
- * .or. btest(irest(ivx,ip),29) ) then
-c
-c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam;
-c flow out of if-loop and into block-wrapup
-c
-c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered
-c voice, but it wasn't first in the list at the same time. So check if
-c prior notes in list have same time
-c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef
-c changes on last note in the list?
-c
- if (btest(isl,15) .and. in.lt.ntot) then
- do 50 iin = in , 1 , -1
- if (tno(iin) .gt. tol) then
- in = iin
- islur(ivx,ip) = ibclr(islur(ivx,ip),15)
- islur(ivxo(in+1),ipo(in+1)) =
- * ibset(islur(ivxo(in+1),ipo(in+1)),15)
- go to 51
- end if
-50 continue
-51 continue
- end if
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
- squez(ib) = 1.
- end if
- istop(ib) = in
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the group, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart and istop are good, so finalize block
-c
- tstart(ib) = to(istart(ib))
- if (istop(ib) .eq. ntot) go to 15
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space and squeeze-factor for upcoming block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
- nb = ib
-c
-c Invert the list of places into ipl(0-7), making it easier to analyze a voice
-c
- do 13 in = 1 , ntot
-c
-c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes.
-c
-c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in)
- ipl2(ivxo(in),ipo(in)) = in
-13 continue
-c
-c Compute elemskips from start of bar to each note in the bar, for beam slopes
-c
- eskzb = 0.
- ib = 1
- do 30 in = 1 , ntot
- if (in .eq. istart(ib)) then
- deskb = squez(ib)*feon(space(ib)/squez(ib))
- else if (tno(in-1) .gt. tol) then
- eskzb = eskzb+deskb
- end if
- eskz(ivxo(in),ipo(in)) = eskzb
- eskz2(ivxo(in),ipo(in)) = eskzb
- if (in .eq. istop(ib)) then
- eskzb = eskzb+deskb
- ib = ib+1
- end if
-30 continue
-c
-c Debug writes
-c
-c print*
-c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot)
-c print*,'PMXB has now got blocks'
-c write(*,'(16i5)')(istart(ib),ib=1,nb)
-c write(*,'(16i5)')(istop(ib),ib=1,nb)
-c write(*,'(16f5.1)')(space(ib),ib=1,nb)
-c write(*,'(16f5.1)')(squez(ib),ib=1,nb)
-c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot)
-cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048,
-c * in=1,ntot)
-c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot)
-c
-c
-c Analyze for beams.
-c
- do 20 iv = 1 , nv
- do 20 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- numbms(ivx) = 0
- mapfb(1) = 0
- mapfb(2) = 0
- mapfb(3) = 0
- mapfb(4) = 0
-c
-c First forced beams.
-c
- if (nfb(ivx) .gt. 0) then
-c
-c tglp2 is time from start of gulp to end of current bar.
-c
- nfbbar = 0
- do 80 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81
- nfbbar = nfbbar+1
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
-c
-c Times from beginning of bar
-c
- itbb1 = int(t1fb(ivx,ifb)-tglp1+tol)
- itbb2 = int(t2fb(ivx,ifb)-tglp1+tol)
- do 83 ip = 1 , nn(ivx)
- if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then
- nip1fb = ip
- do 84 ip1 = ip , nn(ivx)
- inip1 = ipl2(ivx,ip1)
- if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then
- nip2fb = ip1
- itbb3 = itbb2-2
- go to 85
- end if
-84 continue
- end if
-83 continue
- print*
- print*,'Timing problem w/ forced beams'
- write(15,'(/a)')'Timing problem w/ forced beams'
-85 continue
- call logbeam(numnew,nip1fb,nip2fb)
-c
-c Set up mapfb for forced beam just logged:
-c
- ib1 = itbb1/2
- ib2 = itbb3/2
- ibrep = lenbar/ibmrep/2
- do 86 irep = 1 , ibmrep
- ib1now = max(0,ib1-(irep-1)*ibrep)
- ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep)
- mapnow = 0
- do 87 ib = ib1now , ib2now
- mapnow = ibset(mapnow,ib)
-87 continue
- mapfb(irep) = ior(mapfb(irep),mapnow)
-86 continue
-c
-c Since we are cycling thru forced beams, for those that start with a rest and
-c have height & slope adjustments, move adjustments to next note.
-c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at
-c start of beam
-c
- if (btest(irest(ivx,nip1fb),0)) then
-c call setbits(ipl(ivx,nip1fb+1),6,11,
-c * igetbits(ipl(ivx,nip1fb),6,11))
-c call setbits(ipl(ivx,nip1fb+1),6,17,
-c * igetbits(ipl(ivx,nip1fb),6,17))
-c call setbits(islur(ivx,nip1fb+1),2,27,
-c * igetbits(islur(ivx,nip1fb),2,27))
- do 88 kp = nip1fb+1 , nip2fb
- call setbits(ipl(ivx,kp),6,11,
- * igetbits(ipl(ivx,nip1fb),6,11))
- call setbits(ipl(ivx,kp),6,17,
- * igetbits(ipl(ivx,nip1fb),6,17))
- call setbits(islur(ivx,kp),2,27,
- * igetbits(islur(ivx,nip1fb),2,27))
-88 continue
- end if
-80 continue
-81 continue
-c
-c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar.
-c Remember, makeabar is called 1/bar, and it calls findbeam once per voice.
-c
- if (nfbbar .gt. 0) then
- nfb(ivx) = nfb(ivx)-nfbbar
- do 82 ifb = 1 , nfb(ivx)
- t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar)
- t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar)
- ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar)
-82 continue
- end if
- end if
- ifb = 0
-c
-c Done with forced beam masks for this bar and voice. Now get normal beams.
-c
- call findbeam(ibmrep,numbms,mapfb)
-20 continue
- return
- end
- subroutine make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp,
- * isbj2
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,issig,rpndot,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer istart(80),istop(80),iaskb(nm),numbms(nm),
- * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2)
- character*1 ulfbq,udqq,clefq(nm),slurudq
- character*8 noteq
- character*79 cwrq(nm),notexq,inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 soutq,headrq,lowerq
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical bspend,lower,cwrest(nm),vxtup,
- * isgrace,isclef,nofirst,iscln,isdot,isflag,
- * isacc,isfirst,flgndb,btest,stemup,upslur,
- * isgaft,isarp,isrshft,isaccs,iscacc,
- * lowdot,flipend,iscwr,isdotted,beamon1(nm)
- real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80),
- * squez(80)
- logical cwrferm,drawbm
- common /comcwrf/ cwrferm(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comtol/ tol
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur
- * ,WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- logical secondgrace
-c
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c
-c Set up main ib loop within which a block (notes group) is written
-c
- do 25 iv = 1 , nv
- do 25 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ibmcnt(ivx) = 1
- ibmcnt1(ivx) = 1
- beamon(ivx) = .false.
- beamon1(ivx) = .false.
- nornb(ivx) = 0
- iaskb(ivx) = 1
- vxtup(ivx) = .false.
- drawbm(ivx) = .true.
-25 continue
- naskb = 0
- ifig(1) = 1
- ifig(2) = 1
- ixtup = 0
- bspend = .false.
- iscwr = .false.
- rpndot = .false.
- do 16 ib = 1 , nb
-c
-c Check for segno
-c
- if (btest(iornq(1,ipo(istart(ib))),4) .and.
- * ivxo(istart(ib)).eq.1) then
- if (noffseg.le.-10) then
- write(noteq(1:5),'(1H{,i3,1H})')noffseg
- lnoten = 5
- else if (noffseg.lt.0 .or. noffseg.ge.10) then
- write(noteq(1:4),'(1H{,i2,1H})')noffseg
- lnoten = 4
- else
- write(noteq(1:1),'(i1)')noffseg
- lnoten = 1
- end if
- notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9'
- lnote = 15+lnoten
- do 130 iv = 2 , nv
- if (lnote .gt. 60) then
- if (islast) write(11,'(a)')notexq(1:lnote)//'%'
- notexq = sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnoten+9
- else
- notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnote+lnoten+9
- end if
-130 continue
- if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en'
- lnote = 0
- end if
-c
-c Check for new clefs
-c
- isclef = .false.
- if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15))
- * then
-c
-c In preceding line, fl32 gave wrong result for ... .gt.0 !!!
-c
- do 140 in = istart(ib) , istop(ib)
- if (btest(islur(ivxo(in),ipo(in)),11)) then
- call wsclef(ivxo(in),ninow,clefq,
- * iand(ishft(islur(ivxo(in),ipo(in)),-12),7))
- end if
-140 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- isclef = .true.
- end if
-c
-c Start a notes group. We're just gonna define every one using pnotes{n},
-c where \def\pnotes#1{\vnotes#1\elemskip}
-c
- soutq = sq//'pnotes{'
- eonsqz = squez(ib)*feon(space(ib)/squez(ib))
- if (eonsqz .gt. 9.995) then
- write(soutq(9:12),'(f4.1)')eonsqz
- else if (eonsqz .gt. 0.995) then
- write(soutq(9:12),'(f4.2)')eonsqz
- else if (eonsqz .gt. 0.095) then
- soutq = soutq(1:8)//'0.'
- write(soutq(11:12),'(i2)')nint(100*eonsqz)
- else
- soutq = soutq(1:8)//'0.0'
- write(soutq(12:12),'(i1)')nint(100*eonsqz)
- end if
- soutq = soutq(1:12)//'}'
- lsout = 13
-c
-c Check whole block, flag accidentals etc that are too close, one per *time*.
-c Note about bar starts and after rpt's/boublebars: There is an afterruleskip
-c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so
-c (dotsfac*wheadpt) is presumed to be filled up.
-c
- in = istart(ib)-1
- itrpt = -1
- itsig = -1
-c
-c Begin big manual loop over notes in this block; ends at 112
-c
-111 in = in+1
- if (in .gt. istop(ib)) go to 112
- ip = ipo(in)
- ivx = ivxo(in)
- if (ivx .le. nv) then
- iv = ivx
- else
- do 128 iv = 1 , nv
- if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129
-128 continue
- print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2)
- print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2)
- stop
- end if
-129 continue
-c
-c Call precrd here so we know how much space to add for accid's in chords
-c After calling precrd, icashft>0 means there is a shifted chordal accid (incl.
-c main note.
-c
-c To call precrd, need up-downness, so must track if in beam.
-c
-c Deal w/ staff-jumping beams later
-c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
-c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
-c * btest(nacc(ivx,ip),21)) then
-c if (.not.btest(irest(ivx,ip),24)) then
- if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then
- beamon1(ivx)=.true.
- end if
- icashft = 0
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds.
-c
- if (beamon1(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)),
- * .false.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .false.,icashft)
- end if
- end if
-c
-c Turn beam off?
-c
- if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then
- beamon1(ivx) = .false.
- ibmcnt1(ivx) = ibmcnt1(ivx)+1
- end if
-c
-c Remember, rpts & internal sigs can only come at start of (internal) block
-c
- isacc = iand(nacc(ivx,ip),3).gt.0
- * .and. .not.btest(nacc(ivx,ip),17)
- * .and. .not.btest(ipl(ivx,ip),10)
-c
-c i.e., do not set for chord. Now check for "(" as ornament on main note,
-c
-c!!! Need to do this for chord notes too. Maybe in chkarp?
-c
- isaccs = isacc .or. btest(iornq(ivx,ip),0)
-c
-c 5/15/02 Add check for ) ornament of prior note.
-c 5/16 Nope...fails when grace intervenes.
-c if (ip .gt. 1) then
-c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13)
-c end if
- isarp = btest(iornq(ivx,ip),27)
- iscacc = .false.
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord here; check for arpeggios and accidentals. Note accid shifts are
-c not of concern here, only whether there's an accid, whick causes iscacc=.true.
-c
- iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)
- call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
- end if
-c
-c When we get motivated, will do spacing for arpeggios here.
-c
- if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0)
- * itrpt = nint(to(in))
- issig = btest(ipl(ivx,ip),28)
- if (ivx.eq.1 .and. issig) itsig = nint(to(in))
- isgrace = btest(islur(ivx,ip),4) .and.
- * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31)
- isgaft = .false.
- if (ip .gt. 1) then
- xnd = tnote(ipl2(ivx,ip-1))
- isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31)
- isgrace = isgrace .or. isgaft
- end if
- iscln = isclef .and. btest(islur(ivx,ip),11)
-c
-c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd
-c
- isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol
- if (isflag)
- * isflag = .not.btest(irest(ivx,ip-1),0)
- * .and. udqq(nolev(ivx,ip-1),
- * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u'
- if (isflag) then
- do 116 ibmchk = 1 , numbms(ivx)
- if (ip-1 .lt. ibm1(ivx,ibmchk)) then
- go to 117
-c
-c Add check for non-beamed xtuplets. May be problem with stem direction.
-c
-c else if (ip-1.le.ibm2(ivx,ibmchk)) then
- else if (ip-1.le.ibm2(ivx,ibmchk) .and.
- * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then
- isflag = .false.
- go to 117
- end if
-116 continue
- end if
-117 continue
-c
-c If isflag, then won't need to check for dot on prev. note.
-c
-c 5/16/02 ??? Try using this for ) ornament.
-c
- isflag = isflag .or. btest(iornq(ivx,ip-1),13)
- isdot = ip.gt.1
- if (isdot) isdot = isdotted(nodur,ivx,ip-1)
- isrshft = ip .gt. 1
- if (isrshft) isrshft = btest(irest(ivx,ip-1),20)
- if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or.
- * isdot.or.btest(iornq(ivx,ip),26).or.
- * btest(irest(ivx,ip),21).or.isarp.or.
- * btest(irest(ivx,ip),27).or.iscacc)) go to 111
-c
-c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift.
-c Compute pts, the total occupied space including prior notehead.
-c
- wheadpt1 = wheadpt*fullsize(iv)
- pts = wheadpt1
-c
-c Set up for possible cautionary accidental here
-c
- if (isaccs .or. iscacc) then
- if (.not.btest(iornq(ivx,ip),31)) then
- taccfac = accfac
- else
- taccfac = 1.4*accfac
- end if
- end if
- if (isgrace) then
- secondgrace = .false.
- do 122 ig = 1 , ngrace
- if (.not. isgaft) then
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123
- else if (ip .gt. 1) then
- if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123
- end if
-122 continue
- print*,'Problem finding grace index in makeabar'
- stop
-123 continue
-c
-c wgr = distance to backspace (in headwidths), less main acc.
-c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace.
-c spgr = total space needed (w/o main acc).
-c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place.
-c
- if (nng(ig) .eq. 1) then
- wgr = grafac
- if (multg(ig) .eq. 0) wgr = wgr-.4
- else
- wgr = nng(ig)*emgfac
- do 126 ing = 2 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-126 continue
- end if
- if (graspace(ig) .gt. 0.) then
-c
-c User-defined space before grace
-c
- wgr = wgr+graspace(ig)
- end if
- ptgr(ig) = wgr*wheadpt1
- spgr = ptgr(ig)+xb4fac*wheadpt1
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1
- if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac
- pts = pts+spgr
-c
-c Special check for after-grace on ip-1 and normal on ip. Must go back thru
-c loop again for the normal grace.
-c
- if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then
- if (ipg(ig+1).eq.ip) then
- secondgrace = .true.
- ig = ig+1
- go to 123
- end if
- end if
- end if
- if (iscln) then
- pts = pts+clefac*wheadpt1
-c
-c How far to backspace when printing the clef
-c
- ptclef(ivx) = 0.
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc)
- * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1
- if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
- end if
- if (isrshft) then
- pts = pts+rtshfac*wheadpt1
- else if (isflag) then
- pts = pts+flagfac*wheadpt1
- else if (isdot) then
- pts = pts+dotfac*wheadpt1
- end if
- if (abs(to(in)-itrpt) .lt. tol) then
-c
-c Repeat, need a little extra space
-c
- pts = pts+dotsfac*wheadpt1
- end if
- if (isarp) then
- pts = pts+arpfac*wheadpt1
- end if
-c
-c Add in padding space
-c
- pts = pts+xspfac*wheadpt1
-c
-c Now done with all items needing space except accidentals,
-c accidental shifts, and left-notehead-shifts, and will later
-c subtract a notehead if at start of bar.
-c
-c Get available space in elemskips (esk)
-c
-c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or.
-c * to(in) .eq. itsig
- isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or.
- * abs(to(in)-itsig).lt.tol
- if (isfirst) then
-c
-c At start of bar or after repeat sign or new signature
-c
-c if (to(in) .eq. itsig) then
- if (abs(to(in)-itsig).lt.tol) then
- esk = 0.
- else
- esk = fbar
- end if
- else
-c
-c Not 1st note of bar
-c
- esk = eskz(ivx,ip)-eskz(ivx,ip-1)
- end if
- if (isgrace) then
-c
-c Since graces can be very long, cannot assume no interference if prior
-c note uses >1 noteskip. So must get elsk's back to prior note, whether or
-c not it used only one noteskip.
-c <<But if it was xtup. don't need to call eskb4.>>????
-c
-c 10/8/05 Kluge to not zero out esk if in xtup
-c
- esksav = esk
- if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and.
-c * to(in).ne.itsig)
- * abs(to(in)-itsig).gt.tol)
- * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
- if (abs(esk) .lt. tol) esk = esksav
- end if
-c
-c Done getting available elemskips. Remove headwidth if first. Must do here
-c rather than earlier since check uses isfirst
-c
- if (isfirst) pts = pts-wheadpt1
-c
-c Deal with accidental shifts and left-notehead shifts
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c In a chord
-c
- ptsl = 0.
- if (btest(irest(ivx,ip),27)) ptsl = wheadpt1
- ptsadd = max(ptsl,icashft*.05*wheadpt1)
-c
-c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK
-c
- else
-c
-c Not in a chord
-c
- ihshft = 0
- if (isaccs) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
-c if (ihshft .ne. 0) ihshft = max(0,64-ihshft)
- if (ihshft .ne. 0) ihshft = max(0,107-ihshft)
- end if
-c
-c Check for left-shifted main note
-c
- if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft)
- ptsadd = ihshft*.05*wheadpt1
- end if
- pts = pts+ptsadd
- if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd
- if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd
-c
-c Left-shifted, non-chord note before?
-c
- if (ip .gt. 1) then
- if (.not.btest(ipl(ivx,ip-1),10) .and.
- * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1
- end if
-c
-c Try big accidentals first
-c
- ptbneed = pts
- if (isaccs .or. iscacc) then
- ptbneed = ptbneed+wheadpt1*bacfac
- end if
- if (poenom*esk .gt. ptbneed) then
-c
-c Set flag for big accidental
-c
- if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3)
- go to 99
- end if
-c
-c Cannot use big, so try small
-c
- ptsneed = pts
- if (isaccs .or. iscacc) then
- ptsneed = ptsneed+taccfac*wheadpt1
- end if
- if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed,
- * esk,fixednew,scaldold,0.,.false.)
-99 continue
- if (btest(iornq(ivx,ip),26)) then
-c
-c User-defined space. Warning, "zero" may change value in addask!
-c
- zero = 0.
- call addask(to(in),ptsneed,zero,
- * fixednew,scaldold,tglp1,.true.)
- end if
-c
-c End of big manual loop over "in" for accidental checking
-c
- go to 111
-112 continue
-c
-c End of ask analysis for this block.
-c
-c Adjust eskz if there are added spaces. Corrects length of xtup brackets.
-c
- if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom)
-c
-c Check for internal repeat or sig change.
-c
- if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then
- iirpt = iand(islur(1,ipo(istart(ib))),67109216)
- if (iirpt .gt. 0) then
-c
-c Internal repeat
-c
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (iirpt .eq. 96) then
- if (islast) write(11,'(a)')sq//'leftrightrepeat'
- fixednew = fixednew+lrrptfac*wheadpt
- else if (btest(iirpt,5)) then
- if (islast) write(11,'(a)')sq//'leftrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,6)) then
- if (islast) write(11,'(a)')sq//'rightrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,8)) then
- if (islast) write(11,'(a)')sq//'doublebar'
- else
- print*,'Unexpected mid-bar repeat command R*'
- call stop1()
- end if
- scaldold = scaldold-fbar
- end if
- if (btest(ipl(1,ipo(istart(ib))),28)) then
-c
-c Internal signature change.
-c
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'//sq//'afterruleskip}%'
- lnote = 0
- end if
- end if
- flgndb = .false.
-c
-c Done with start-of-block stuff. Begin main loop over voices.
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- icm = midchan(iv,kv)
-c
-c A rather klugey way to set flag for figure in this voice
-c Must always check figbass before figchk.
-c
- if (figbass) then
- ivf = 0
- if (ivx .eq. 1) then
- ivf = 1
- else if (ivx .eq. ivxfig2) then
- ivf = 2
- end if
- if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0
- end if
- if (ivx .gt. 1) then
- if (ivx .le. nv) then
- call addstr(sepsymq(iv-1),1,soutq,lsout)
- else
- call addstr(sq//'nextvoice',10,soutq,lsout)
- end if
- end if
- if (ihdht.gt.0 .and. ivx.eq.nv) then
-c
-c Write header. First adjust height if needed to miss barno.
-c
- if (bar1syst .and. iline.ne.1) then
- ihdht = 15+irzbnd+isnx
- end if
-c
-c Add user-defined vertical shift
-c
- ihdht = ihdht+ihdvrt
- lchead = lenstr(headrq,80)
- notexq = sq//'zcharnote{'
- write(notexq(12:13),'(i2)')ihdht
- notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt '
- call addstr(notexq,34,soutq,lsout)
- call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout)
- ihdht = 0
- end if
- if (lower .and. ivx.eq.nv) then
- lclow = lenstr(lowerq,80)
- call addstr(sq//'zcharnote{-6}{'//
- * sq//'tempo'//sq//'kern-10pt '//
- * lowerq(1:lclow)//'}',33+lclow,soutq,lsout)
- lower=.false.
- end if
- tnow = tstart(ib)
- nofirst = .true.
-c
-c Done setting up voice ivx for start of block ib. Loop over notes in voice.
-c
- do 10 jn = istart(ib), istop(ib)
- if (ivxo(jn) .ne. ivx) go to 10
- ip = ipo(jn)
-c
-c May have problem with not initializing islhgt, so do it here
-c
- islhgt = 0
-c
- if (nofirst) then
- noctup = 0
- if (ncmid(iv,ip) .eq. 23) noctup = -2
- nofirst = .false.
- end if
-c
-c Check for internal floating figure (before last note of group).
-c
-12 if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol)
- * then
-c
-c Bypassed figure location. Backup, place fig, return.
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,
- * lsout)
- go to 12
- end if
- end if
- end if
-c
-c Put in \sk if needed
-c
- if (to(jn) .gt. tnow+tol) then
- call addstr(sq//'sk',3,soutq,lsout)
- tnow = tnow+space(ib)
- go to 12
- end if
-c
-c Check for user-defined shifts
-c
- if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16))
- * call putshft(ivx,.true.,soutq,lsout)
-21 if (iaskb(ivx).le.naskb .and.
- * tnow.gt.task(iaskb(ivx))-tol) then
- if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then
-c
-c Insert placeholder for accidental skip
-c
- call addstr(sq//'ask ',9,soutq,lsout)
- nasksys = nasksys+1
- wasksys(nasksys) = wask(iaskb(ivx))
- if (wask(iaskb(ivx)) .gt. 0.) then
- elasksys(nasksys) = elask(iaskb(ivx))
- else
-c
-c This is a signal to permit negative ask's. Should really have elask>=0.
-c
- elasksys(nasksys) = -elask(iaskb(ivx))
- end if
- end if
-c
-c May have skipped some task's in earlier blocks (due to void voice)
-c
- iaskb(ivx) = iaskb(ivx)+1
- go to 21
- end if
- if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and.
- * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then
-c
-c Figure on a note. NB: later special check for late figs.
-c
- call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout)
- end if
- end if
- end if
-c
-c Check for new clef here.
-c
- if (isclef .and. btest(islur(ivx,ip),11)) then
-c print*,'At clef insertion, ptclef:',ptclef(iv)
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{-'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(7:9),'(f3.1)')ptclef(iv)
- lnote = 9
- else
- write(notexq(7:10),'(f4.1)')ptclef(iv)
- lnote = 10
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
-c print*,'Just added: ',notexq(1:lnote)
- end if
- call clefsym(islur(iv,ip),notexq,lnote,nclef)
- call addstr(notexq,lnote,soutq,lsout)
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(6:8),'(f3.1)')ptclef(iv)
- lnote = 8
- else
- write(notexq(6:9),'(f4.1)')ptclef(iv)
- lnote = 9
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
- end if
- end if
-c
-c Checking for literal TeX string BEFORE starting beams!!
-c
- if (btest(islur(ivx,ip),16)) then
- do 124 il = 1 , nlit
- if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125
-124 continue
- print*,'Problem finding index for literal string'
- call stop1()
-125 continue
-c
-c Write a type 1 tex string.
-c
- if (lenlit(il) .lt. 71) then
-c
-c Add normally
-c
- call addstr(litq(il),lenlit(il),soutq,lsout)
- else
-c
-c Longer than 71. Write souq, Write string, start new soutq.
-c
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%'
- lsout = 0
- end if
- end if
-c
-c Arpeggio on a main (non-chordal) note?
-c
- if (btest(iornq(ivx,ip),27)) then
-c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip),
- call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip),
- * soutq,lsout)
- end if
-c
-c See if a beam starts here
-c
- if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
- * btest(nacc(ivx,ip),21)) then
- if (.not.btest(irest(ivx,ip),24)) then
-c
-c Not a jump start
-c
- call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
-c
-c Shift beam start if notehead was shifted
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout)
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
- else
-c
-c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set
-c to 0 at end of first part of jump beam
-c
- ivbj2 = ivx
-c
-c Check for xtup since we bypassed beamstrt wherein vxtup is normally set
-c
- if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2)
- * vxtup(ivx) = .true.
-c
-c Since beamstrt is not called, and drawbm is normally set there, need to set
-c it here. This could cause problems if someone tries a staff-jumping,
-c unbarred beam, which I'll deal with when it comes up.
-c
- drawbm(ivx) = .true.
- end if
- if (ixrest(ivx) .eq. 0) then
- beamon(ivx) = .true.
- bspend = .true.
- if (.not.btest(irest(ivx,ip),24))bspend = .true.
- end if
- end if
-c
-c Setup for chords and possible slurs in chords
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Just rerun precrd. Klunky, but saves
-c me from tracking down errors instroduced when I moved 1st call
-c forward for accidental spacing analysis.
-c
- if (beamon(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)),
- * .true.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .true.,icashft)
- end if
- end if
-c
-c Is there slur or grace activity?
-c
- isgrace = btest(islur(ivx,ip),4)
- if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31)
-c
-c isgrace if not 1st note in bar and previous note has Way-after grace.
-c
- if (btest(islur(ivx,ip),0) .or. isgrace) then
- if (btest(islur(ivx,ip),0)) then
- if (fontslur) then
-c
-c Call routine for non-postscript slurs
-c
- call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- else
-c
-c Postscript slurs
-c
- call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3,
- * isdat4,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- end if
- end if
- if (isgrace) then
-c
-c Grace note.
-c
- iphold = ip
- isgrace = .false.
- if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31)
- if (isgrace) iphold = iphold-1
- isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31)
- * .and..not.btest(ipl(ivx,ip),29))
-c
-c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace
-c on current note. Do A-grace on current note, and W-grace at barend, later.
-c
- if (isgrace) then
- call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,iphold),.false.,
- * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx),
- * tnote(ipl2(ivx,ip)),ulq)
- if (slurg(ig)) then
-c
-c Terminate slur started in dograce. Get direction of main note stem
-c
- if (.not.beamon(ivx)) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or.
- * tnote(ipl2(ivx,ip)).gt.63
- call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0,
- * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur)
- end if
- end if
- end if
- if (btest(iornq(ivx,ip),24)) then
-c
-c Start slur on main note for After- or Way-after-grace.
-c
-c???? ndxslur = log2(33554431-listslur)
- ndxslur = log2(16777215-listslur)
-c
-c Get note name
-c
- call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
-c
-c Get slur direction
-c
- slurudq = 'u'
- if (.not.beamon(ivx)) then
- if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd'
- else
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd'
- end if
-c
-cc Replace ndxslur by 11-ndxslur when printing only.
-c Replace ndxslur by 23-ndxslur when printing only.
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c notexq = sq//'islur'//slurudq//chax(59-ndxslur)
- notexq = sq//'islur'//slurudq//chax(71-ndxslur)
- * //noteq(1:lnoten)
- call addstr(notexq,8+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- else
- notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- end if
-c call setbits(ipl(ivx,ip),4,23,ndxslur)
- call setbits(ipl(ivx,ip),5,23,ndxslur)
- if (btest(ipl(ivx,ip),31))
-c
-c Starting slur on W-grace on THIS note. Record ndxslur.
-c
- * listslur = ibset(listslur,ndxslur)
- end if
- end if
-c
-c Process dynamic marks
-c
- if (btest(irest(ivx,ip),26)) then
- call dodyn(ivx,ip,
- * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip),
- * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq,
- * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout)
- end if
-c
-c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st.
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c Need a duration to set type of note head
-c
-c if (.not. vxtup(ivx)) then
-c
-c Clumsy test, but vxtup is not set until main note is processed.
-c
- if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then
- nodu = nodur(ivx,ip)
-c else if (mult(ivx,ip) .lt. 0) then
- else if (iand(mult(ivx,ip),15)-8 .lt. 0) then
- nodu = 32
- else
- nodu = 16
- end if
- call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout,
- * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv,
- * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen,
- * btest(nacc(ivx,ip),27),nacc(ivx,ip))
- end if
-c
-c Now that chords are done, add stuff to midi file
-c
-c if (ismidi) call addmidi(icm,nolev(ivx,ip),
- if (ismidi) call addmidi(icm,
- * nolev(ivx,ip)-iTransAmt(instno(iv)),
-c
- * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)),
- * btest(irest(ivx,ip),0),.false.)
-c
-c Check for breath or caesura
-c
- if (btest(iornq(ivx,ip),28)) then
- call putcb(ivx,ip,notexq,lnote)
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Check for main-note ornaments. ')' on dotted notes go in with note, not here.
-c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD
-c
- isacc = iand(iornq(ivx,ip),4194287) .gt. 0
-c
-c isacc=.true. if any ornament except segno
-c
- if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then
-c
-c If ). is only ornament, bypass. If with others, temporarirly zero the bit.
-c
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (iand(iornq(ivx,ip),516079) .eq. 0) then
-c
-c ). is the only non-segno ornament
-c
- isacc = .false.
- else
-c
-c There are other ornaments in addition
-c
- rpndot = .true.
- iornq(ivx,ip) = ibclr(iornq(ivx,ip),13)
- end if
- end if
- end if
- if (isacc .and. .not.cwrferm(ivx)) then
-c
-c Check for centered whole-bar rest with fermata (bits 10 or 14).
-c
- if (iand(iornq(ivx,ip),17408).gt.0
- * .and. btest(irest(ivx,ip),0) .and.
- * nodur(ivx,ip).eq.lenbar .and.
- * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
- cwrferm(ivx) = .true.
- go to 30
- end if
- call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip),
- * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen,
- * notexq,lnote,ip,islhgt,beamon(ivx),
- * btest(ipl(ivx,ip),10))
- call addstr(notexq,lnote,soutq,lsout)
- end if
- if (rpndot) then
- iornq(ivx,ip) = ibset(iornq(ivx,ip),13)
- rpndot = .false.
- end if
-30 continue
-c
-c Check for main note accidental
-c
- if (iand(nacc(ivx,ip),3).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
- if (ihshft .ne. 0) ihshft=ihshft-107
- if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8))
-c
-c Not a chord, and left-shifted main note, so left-shift accid
-c
- * ihshft = ihshft-20
- call doacc(ihshft,igetbits(nacc(ivx,ip),6,4),
- * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip),
- * btest(irest(ivx,ip),31))
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Lower dot for lower-voice notes. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest
-c. 5. Flag (lowdot) is set to true
-c 6. Not in an xtuplet
-c
- if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv
- * .and. nodur(ivx,ip).ne.0) then
- if (.not.btest(irest(ivx,ip),0) .and.
- * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and.
- * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then
- if (btest(irest(ivx,ip),19)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- updot(ivx,ndotmv(ivx)+1) =
- * updot(ivx,ndotmv(ivx)+1)-2.
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,
- * igetbits(islur(ivx,ip),1,3))
- end if
- end if
- end if
-c
-c Check for dotted notes with moved dots
-c
- if (btest(irest(ivx,ip),19)) then
- ndotmv(ivx) = ndotmv(ivx)+1
- call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)),
- * soutq,lsout,igetbits(islur(ivx,ip),1,3))
- end if
-c
-c Stemlength shortening?
-c
- if (btest(mult(ivx,ip),27)) then
- stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5
- call addstr(sq//'stemlength{',12,soutq,lsout)
- write(notexq,'(f4.2)')stemshort
- call addstr(notexq(1:4)//'}',5,soutq,lsout)
- else if (ip .gt. 1) then
- if (btest(mult(ivx,ip-1),27))
-c
-c Cancel shortening. Looks like it gets automatically restored if new inst. or
-c new line, so no need to worry about affecting other lines
-c
- * call addstr(sq//'stemlength{4.66}',17,soutq,lsout)
- end if
-c
-c Zero out slur-height marker for raising ornaments
-c
- islhgt = 0
-c
-c Now start with spacing notes. Is a beam start pending?
-c
- if (bspend .and.
- * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then
- if (ixrest(ivx) .eq. 4) then
-c
-c Special path for single note at end of otherwise beamed xtup
-c
- ixrest(ivx) = 0
- else
- call beamn1(notexq,lnote)
- end if
- bspend = .false.
-c
-c Is a beam ending?
-c
- else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
-c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then
- * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or.
- * btest(nacc(ivx,ip),20))) then
- if (bspend) then
-c
-c Must be a single-note ending of a jump-beam
-c
- bspend = .false.
- end if
- call beamend(notexq,lnote)
- if (.not.btest(nacc(ivx,ip),20)) then
- vxtup(ivx) = .false.
- nornb(ivx) = 0
- ibmcnt(ivx) = ibmcnt(ivx)+1
- beamon(ivx) = .false.
- end if
-c
-c Or if we're in the middle of a beam
-c
- else if (numbms(ivx).gt.0 .and. beamon(ivx)) then
- call beamid(notexq,lnote)
-c
-c Or whole-bar rest
-c
- else if (btest(irest(ivx,ip),0)
- * .and. nodur(ivx,ip).eq.lenbar
- * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)
- * .and..not.btest(irest(ivx,ip),25)
- * .and..not.btest(islur(ivx,ip),29)) then
-c
-c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp
-c
- cwrest(ivx) = .true.
- iscwr = .true.
- call notex(cwrq(ivx),lcwr(ivx))
- tnow = tnow+lenbar
- go to 10
- else if (ixrest(ivx) .eq. 0) then
-c
-c Before writing note or rest, check for keyboard rest height adjustment.
-c Conditions are 0. This is a non-blank rest
-c 1. kbdrests = .true.
-c 2. There are two voices on the staff
-c 3. No user-def height adjustments have been applied (nolev<50)
-cc 4. Not last note in bar
-cc 5. Followed by note (add better test later)
-c
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
-c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx)
-c * .and. .not.(btest(irest(ivx,ip+1),0))) then
- * nolev(ivx,ip).le.50) then
-c
-c Get reference level: next following note if no intervening blank rests,
-c otherwise next prior note.
-c
-c levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line
- if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then
-c
-c Not the last note and not "look-left" for level
-c
- do 8 kkp = ip+1 , nn(ivx)
- if (btest(islur(ivx,kkp),29)) go to 4
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-8 continue
- end if
-4 continue
-c
-c If here, there were no following notes or came to a blank rest, or
-c "look-left" option set. So look before
-c
- if (ip .eq. 1) go to 2 ! Get out if this is the first note.
- do 3 kkp = ip-1, 1, -1
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-3 continue
- go to 2 ! Pretty odd, should never be here, but get out if so.
-9 continue
-c
-c Find note in other voice at same time
-c
- iupdown = sign(1,ivx-nv-1)
- ivother = ivmx(iv,(3-iupdown)/2)
- tother = 0.
- do 5 kkp = 1 , nib(ivother,ibar)
- if (abs(tother-tnow) .lt. tol) go to 6
- tother = tother+nodur(ivother,kkp)
-5 continue
-c
-c If here, then no note starts in other voice at same time, so set default
-c
- levother = -iupdown*50
- go to 7
-6 continue
-c
-c If here, have just identified a simultaneous note or rest in other voice
-c
- if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it
- levother = nolev(ivother,kkp)-ncmid(iv,ip)+4
- else
- if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then
-c
-c Rest in other voice has same duration, get out (so defualt spacing is used)
-c
- go to 2
- end if
- levother = -iupdown*50
- end if
-7 continue
- indxr = log2(nodur(ivx,ip))+1
- if (iupdown .lt. 0) then
- levtop = levtopr(indxr)
- iraise1 = levother-levtop-3 ! Based on other note
- iraise2 = levnext-levtop ! Based on following note
- if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2
- iraise = min(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levtop.gt.-1) iraise = iraise-1
- else
- levbot = levbotr(indxr)
- iraise1 = levother-levbot+3
- iraise2 = levnext-levbot
- if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1
- iraise = max(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levbot.le.9) iraise = iraise-1
- end if
- nolev(ivx,ip) = 100+iraise
- end if
-2 continue
-c
-c Write a separate note or rest
-c
- call notex(notexq,lnote)
- end if
-c
-c Right offset? This may cause trouble
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (ixrest(ivx).eq.0 .and. lnote.gt. 0)
- * call addstr(notexq,lnote,soutq,lsout)
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
-c
-c Terminate user-defined offsets. Fix format
-c
- if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17))
- * call putshft(ivx,.false.,soutq,lsout)
-c
-c Deal with After- and Way-after-graces. First, if end of bar, compute space
-c needed since it wasn't done during general ask-checks. If extra space is
-c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp.
-c But will still need to add extra space as hardspace.
-c
- if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or.
- * btest(ipl(ivx,ip),29))) then
- do 77 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78
-77 continue
- print*,'Problem finding grace index at "do 77"'
- call stop1()
-78 continue
-c
-c Get elemskip to end of bar. WON'T WORK IF XTUPS !!
-c
- esk = 0.
- do 40 iib = ib , nb
- if (iib .eq. ib) then
- itleft = nint(to(ipl2(ivx,ip)))
- else
- itleft = nint(tstart(ib))
- end if
- if (iib .lt. nb) then
- itright = nint(tstart(iib+1))
- else
- itright = lenbar
- end if
- esk = esk+feon(space(ib))*
- * (itright-itleft)/space(ib)
-40 continue
- ptsavail = poenom*esk-wheadpt
- if (nng(ig) .eq. 1) then
- wgr = grafac
- else
- wgr = nng(ig)*emgfac
- do 41 ing = 1 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-41 continue
- end if
- ptgr(ig) = wgr*wheadpt
- ptsneed = (wgr+0.5)*wheadpt
- ptsndg(ivx) = 0.
- if (ptsavail .lt. ptsneed) then
- ptsndg(ivx) = ptsneed
- eskndg(ivx) = esk
- if (btest(ipl(ivx,ip),31)) then
-c
-c Convert GW to GA
-c
- ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29)
- end if
- end if
- end if
-c
-c Check for GA
-c
- if (btest(ipl(ivx,ip),29))
- * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,ip),.false.,
- * .false.,0,0,0,0,0,0,0.,ulq)
-c
-c Update running time
-c
- tnow = tnow+space(ib)
-10 continue
-c
-c Have finished last note in this voice and block
-c
- itendb = nint(to(istop(ib))+space(ib))
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
-17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then
-c
-c There's at least one figure left. offnsk could be <0
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout)
- go to 17
- end if
- end if
-c
-c Check for flag, dot, or upstem on last note of bar.
-c
- if (ib .eq. nb) then
- ip = ipo(ipl2(ivx,nn(ivx)))
- flgndv(ivx) = 0.
- if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then
- if (space(ib) .lt. 16.-tol) then
-c
-c Note in last space, smaller than a quarter note.
-c
- if ((.not.btest(irest(ivx,ip),0) .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u')
- * .or. isdotted(nodur,ivx,ip)) then
-c
-c Upstem non-rest, or dotted
-c
- if (numbms(ivx).gt.0
- * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx)))
- * .and. .not.isdotted(nodur,ivx,ip))
- * then
-c
-c In beam and not dotted, so use smaller space
-c
- flgndv(ivx) = upstmfac
- else
- flgndv(ivx) = flagfac
- end if
- end if
- else
-c
-c Last space, nonflagged (no beam) only worry dot or up
-c
- if (isdotted(nodur,ivx,ip)) then
- flgndv(ivx) = flagfac
- else if (tnote(ipl2(ivx,ip)).lt.64 .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u') then
-c
-c Upstem on last note , non-flagged
-c
- flgndv(ivx) = upstmfac
- end if
- end if
- end if
-c
-c Check for right-shifted chordal note
-c
- if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac
- flgndb = flgndb .or. flgndv(ivx).gt.0.
- if (ismidi) then
-c
-c For midi, set flags for accidentals on last note of bar. Assume they affect
-c first note of next bar whether or not tied.
-c Note has already been done, so next entry into addmidi is 1st in new bar.
-c First do main note, then chord notes
-c
-c Gyrations needed to account for multi-bar tied full-bar notes?
-cc Old old lbacc(icm) = iand(nacc(ivx,ip),7)
-c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7)
-c
- if (iand(nacc(ivx,ip),7) .gt. 0) then
-c
-c Explicit accidental on last main note in bar
-c
- do 55 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56
-55 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolev(ivx,ip)
- jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7))
- end if
-56 continue
- if (btest(ipl(ivx,ip),10) .and. crdacc) then
- do 57 icrd = icrd1 , icrd2
- iacc = igetbits(icrdat(icrd),3,20)
- if (iacc .gt. 0) then
-c
-c Explicit accidental on chord note at end of bar
-c
- nolevc = igetbits(icrdat(icrd),7,12)
- do 58 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolevc) go to 59
-58 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolevc
- jaccbl(icm,naccbl(icm)) = iashft(iacc)
- end if
-59 continue
-57 continue
- end if
-c if (lbacc(icm).eq.0 .and. accb4(icm)) then
- do 65 kacc = 1 , naccim(icm)
-c
-c If naccim(icm)>0,
-c possible implicit accidental from earlier in the bar. Check for prior accid
-c in this bar at relevant note levels, main and chord notes. Only act if no
-c explicit action from just above. Assuming any accid on last note in bar,
-c either explicit or implicit, has same effect on 1st note of next bar.
-c
- if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66
- if (btest(ipl(ivx,ip),10)) then
- do 67 icrd = icrd1 , icrd2
- if (iand(ishft(icrdat(icrd),-12),127) .eq.
- * laccim(icm,kacc)) go to 66
-67 continue
- end if
- go to 65
-66 continue
-c
-c So far we know there is a main or chord note at level laccim(icm,kacc). So
-c it will get a bl-accid if it didn't just already get one.
-c
- do 68 macc = 1 , naccbl(icm)
- if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65
-68 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = laccim(icm,kacc)
- jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc)
-65 continue
- end if
- end if
-11 continue
-c
-c Close out the notes group
-c
- call addstr(sq//'en',3,soutq,lsout)
- if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
-16 continue
-c
-c Check for way-after graces at end of bar. We could not link these to notes
-c as in midbar since there is no note following grace! Also, set flag if
-c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop.
-c
- isgrace = .false.
- do 75 iv = 1 , nv
- nvmxsav(iv) = nvmx(iv)
- do 75 kv = 1 , nvmx(iv)
- ivmxsav(iv,kv) = ivmx(iv,kv)
- ivx = ivmx(iv,kv)
- ptsgnd = 0.
- if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31))
- * .and. ptsndg(ivx).gt.0.) then
- flgndb = .true.
- if (ptsndg(ivx) .gt. ptsgnd) then
- ptsgnd = ptsndg(ivx)
- eskgnd = eskndg(ivx)
- end if
- end if
- if (btest(ipl(ivx,nn(ivx)),31)) then
-c
-c This voice has a way-after grace here at end of bar
-c
- if (.not.isgrace) then
-c
-c This is the first one, so set up the string
-c
- isgrace = .true.
- ivlast = 1
- soutq = sq//'znotes'
- lsout = 7
- end if
- do 76 iiv = ivlast , iv-1
- call addstr(sepsymq(iiv),1,soutq,lsout)
-76 continue
- ivlast = iv
-c
-c No need to put in 'nextvoice', even if 2 lines/staff
-c
- call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)),
- * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true.,
- * .false.,0,0,0,0,0,0,0.,ulq)
- end if
-75 continue
- if (isgrace) then
- call addstr(sq//'en%',4,soutq,lsout)
- if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout)
- end if
- lsout = 0
-c
-c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest
-c This has to be the only use of atnextbar
-c
-c if (ibar .eq. ibarmbr) then
- if (ibar.eq.ibarmbr .and. islast) then
-c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq//
-c * 'mbrest{',30,soutq,lsout)
-c ndig = int(alog10(mbrest+.01))+1
-c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest
-c lsout = lsout+ndig
-c call addstr('}{',2,soutq,lsout)
-c mtrspc = .5+xb4mbr
-c xb4mbr = 0.
-c if (mtrspc .eq. 0) then
-c ndig = 1
-c else
-c ndig = int(alog10(mtrspc+.01))+1
-c end if
-c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc
-c lsout = lsout+ndig
-c call addstr('}0'//sq//'en}%',7,soutq,lsout)
-c if (islast) write(11,'(a)')soutq(1:lsout)
-c lsout = 0
-c ndig = int(alog10(mbrest-1+.01))+1
-c if (mbrest.eq.1) ndig=1
-c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)')
-c * sq//'advance'//sq//'barno',mbrest-1,'%'
-c++
- soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes'
- lsout = 22
- notexq = sq//'mbrest'
- lnote = 7
- call istring(mbrest,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)
- lnote = lnote+len
- mtrspc = .5+xb4mbr
- xb4mbr = 0.
- call istring(mtrspc,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)//'0'
- lnote = lnote+len+1
- do 62 iv = 1 , nv
- call addstr(notexq,lnote,soutq,lsout)
- if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-62 continue
- call addstr(sq//'en}%',5,soutq,lsout)
- write(11,'(a)')soutq(1:lsout)
- lsout = 0
- if (mbrest .gt. 1) then
- ndig = int(alog10(mbrest-1+.01))+1
- write(11,'(a14,i'//chax(48+ndig)//',a1)')
- * sq//'advance'//sq//'barno',mbrest-1,'%'
- end if
- else if (iscwr) then
-c
-c Centered whole-bar rests
-c
- call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22,
- * soutq,lsout)
- do 60 iv = 1 , nv
- lnote = 0
- do 61 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (cwrest(ivx)) then
- if (lnote .eq. 0) then
- notexq = sq//'centerbar{'
- lnote = 11
- end if
- if (.not.cwrferm(ivx)) then
- if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then
-c
-c Kluge to use new definitions for centered, stacked rests
-c
- if (cwrq(ivx)(2:10).eq.'liftpause' .or.
- * cwrq(ivx)(2:10).eq.'liftPAuse')
- * cwrq(ivx)(10:10) = 'c'
- end if
- notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx))
- lnote = lnote+lcwr(ivx)
- else
-c
-c Fermata on centered rest. Will need to fix up level.
-c 12/6/07 shift it left so it's centered over rest
-c
-c notexq = notexq(1:lnote)
-c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx))
-c lnote = lnote+11+lcwr(ivx)
-c
- notexq = notexq(1:lnote)//sq//'loffset{.39}{'
- * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx))
- lnote = lnote+26+lcwr(ivx)
- cwrferm(ivx) = .false.
- end if
- end if
-61 continue
- if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1,
- * soutq,lsout)
- if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-60 continue
- call addstr(sq//'en}',4,soutq,lsout)
- if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
- end if
-c
-c End of block for centered whole-bar rests and multi-bar rests
-c
-c If at end of block, save durations of last notes in bar, for possible use
-c if clef changes at start of next bar
-c
- if (ibar .eq. nbars) then
- do 63 iv = 1 , nv
- do 63 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
-c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255))
- prevtn(ivx) = tnote(ipl2(ivx,nn(ivx)))
-63 continue
- end if
-c
-c Update time for midi. This is only used for the event track
-c
- if (ismidi) then
- miditime = miditime+15*lenbar
-c
-c If pickup, write the real time signature to the event track. Cannot use
-c mtrnuml since it was reset to 0, have to recompute it
-c
- if (lenb0 .eq. lenbar)
- * call midievent('m',mtrdenl*lenb1/64,mtrdenl)
- end if
- return
- end
- subroutine makeabar()
-c
-c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for
-c xtups, since only last note of xtup gets non-zero nodur, which
-c corresponds to single note of full length of xtup.
-c In this subroutine we make an ordered list of all notes in all voices.
-c ilnc = list note counter
-c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note.
-c to(ilnc) = real start time of note in PMX-units (64=whole note)
-c tno(ilnc) = time to next event in the bar.
-c tnote(ilnc) = actual duration of note
-c Then run thru list, grouping consecutive notes into \notes groups ib.
-c space(ib) = real time unit for the \notes group
-c squez(ib) = factor on space to get effective space. This will be 1 if
-c there is a note exactly spanning each interval of space, and
-c <1 if not.
-c Details: let eon = elemskips per noteskip (like length). Basic formula is
-c eon = sqrt(space/2.)
-c If tgovern >= space, then
-c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern).
-c Time needed to give this eon using basic formula is
-c teq = space**2/tgovern
-c Factor on space to get teq is
-c squez(ib) = space/tgovern
-c The eon for each ib can then be computed based on time of space*squez.
-c Iff squez = 1, there is a note spanning every increment in the \notes group.
-c
-c tnminb = minimum time span in the bar for increments spanned by notes,
-c i.e., with squez=1. Use after parsing into line to decide if
-c spacing needs to be "flattened" among notes groups.
-c
- common /comtol/ tol
- parameter (nm=24,nkb=3999,maxblks=4000)
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- logical rest,firstline,newmeter,gotclef
- integer cnn(nm),istart(80),istop(80)
- real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600)
- elskb = 0.
- tnminb(ibarcnt) = 1000.
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv)
-c
- ilnc = 1
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cnn(ivx) = 1
- ivxo(ilnc) = ivx
- ipo(ilnc) = 1
- to(ilnc) = 0.
- tnote(ilnc) = fnote(nodur,ivx,1,nacc)
- xit(ivx) = tnote(ilnc)
- if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000.
- ilnc = ilnc+1
-4 continue
-c
-c Build the list
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iv = 1 , nv
- do 6 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- tminn = min(tmin,xit(ivx))
- if(tminn .lt. tmin) then
- tmin = tminn
- ivnext = ivx
- end if
-6 continue
- if (tmin .gt. 999.) go to 7
- ivxo(ilnc) = ivnext
- cnn(ivnext) = cnn(ivnext)+1
- ipo(ilnc) = cnn(ivnext)
- to(ilnc) = tmin
-c
-c Check if this voice is done
-c
- tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc)
- if (cnn(ivnext) .eq. nn(ivnext)) then
- xit(ivnext) = 1000.
- else
- xit(ivnext) = xit(ivnext)+tnote(ilnc)
- end if
- ilnc = ilnc+1
- go to 5
-7 continue
- ntot = ilnc-1
- if (ntot .gt. 600) then
- call printl(' ')
- call printl('Cannot have more than 600 notes per bar, stopping')
- call stop1()
- end if
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc)
- tnote(ntot) = tno(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(tnote(in),in=1,ntot)
-c
-c Done w/ list. Initialize loop for building note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c Start the loop
-c
-9 continue
- if (in .eq. ntot) then
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
-c
-c Last gap in bar is spanned by a note, so cannot need a squeeze.
-c
- squez(ib) = 1.
- end if
- istop(ib) = ntot
-c
-c From here flow out of this if block and into block-setup
-c
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
-c
-c Tentative space tno(in) is non-zero. Set squez, which will be kept (since
-c it is a unique property of the particular increment starting here) :
-c
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the space, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
-c
-c Next increment has same space. Does it have same squez?
-c
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
-c
-c If it does have the same squez, loop, otherwise flow out
-c
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart, istop, space, and squez are good, so close out block
-c
- tstart(ib) = to(istart(ib))
-c
-c Compute elemskips assuming no flattening to increase min space. The formula
-c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible
-c flattening in pmxb), elsperns = squez*feon(space/squez)
-c
- elsperns = f1eon(space(ib)*squez(ib))
- if (istop(ib) .eq. ntot) then
- nnsk = nint((lenbar-tstart(ib))/space(ib))
- else
- nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib))
- end if
- elskb = elskb+elsperns*nnsk
- if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then
- call catspace(space(ib),squez(ib),nnsk)
- else
-c
-c This is the first entry for this bar
-c
- nnpd(nptr(ibarcnt)) = nnsk
- durb(nptr(ibarcnt)) = space(ib)
- sqzb(nptr(ibarcnt)) = squez(ib)
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- end if
-c
-c Update minimum space spanned by a note
-c
- if (abs(squez(ib)-1) .lt. tol)
- * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib))
- if (istop(ib) .eq. ntot) go to 15
-c
-c End of spatial accounting for now
-c
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space for new block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
-c nb = ib
-c
-c Debug writes
-c
-c write(*,'(16i5)')(istart(ib),ib=1,nb)
-c write(*,'(16i5)')(istop(ib),ib=1,nb)
-c write(*,'(16f5.1)')(space(ib),ib=1,nb)
-c write(*,'(16f5.1)')(squez(ib),ib=1,nb)
-c
- return
- end
- subroutine midievent(typeq,in1,in2)
-c
-c We now store "conductor" events in mmidi(numchan,.), and count bytes
-c with imidi(numchan)
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comevent/ miditime,lasttime
- character*1 typeq
- idur = isetvarlen(miditime-lasttime,nbytes)
- imidi(numchan) = imidi(numchan)+nbytes+1
- do 1 i = 1 , nbytes
- mmidi(numchan,imidi(numchan)-i) = mod(idur,256)
- idur = ishft(idur,-8)
-1 continue
- mmidi(numchan,imidi(numchan)) = 255
- if (typeq .eq. 't') then
-c
-c Tempo event. in1 = quarters per minute (integer)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+1
- mmidi(numchan,imidi(numchan)+2) = 3
- misperq = nint(60000000./in1)
- do 2 i = 1 , 3
- mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256)
- misperq = ishft(misperq,-8)
-2 continue
- imidi(numchan) = imidi(numchan)+5
- else if (typeq .eq. 'm') then
-c
-c Meter event. in1=numerator, in2=denom (power of 2)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+8
- mmidi(numchan,imidi(numchan)+2) = 4
- mmidi(numchan,imidi(numchan)+3) = in1
- if (in2 .gt. 0) then
- mmidi(numchan,imidi(numchan)+4) = log2(in2)
- else
- mmidi(numchan,imidi(numchan)+4) = 0
- end if
- mmidi(numchan,imidi(numchan)+5) = 24
- mmidi(numchan,imidi(numchan)+6) = 8
- imidi(numchan) = imidi(numchan)+6
- else if (typeq .eq. 'k') then
-c
-c Keychange event. in1 = isig
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+9
- mmidi(numchan,imidi(numchan)+2) = 2
- mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256)
- mmidi(numchan,imidi(numchan)+4) = 0
- imidi(numchan) = imidi(numchan)+4
- else
- print*,'Program flameout in midievent'
- call stop1()
- end if
- lasttime = miditime
- return
- end
- subroutine moveln(iuin,iuout,done)
- logical done
- character*129 outq
- done = .false.
- read(iuin,'(a)',end=1) outq
- lenout = llen(outq,129)
- write(iuout,'(a)') outq(1:lenout)
- return
-1 done = .true.
- return
- end
- subroutine mrec1(lineq,iccount,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=4000)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- function ncmid(iv,ip)
- parameter (nm=24)
- common /all/ mult(nm,200),jv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- if (ncc(iv) .eq. 1) then
- ncmid = ncmidcc(iv,1)
- else
- xtime = to(ipl2(ivx,ip))
- do 1 icc = ncc(iv) , 1 , -1
- if (xtime .gt. tcc(iv,icc)-tol) then
- ncmid = ncmidcc(iv,icc)
- return
- end if
-1 continue
- print*,'Problem in ncmid()'
- stop
- end if
- end
- function ncmidf(clefq)
-c
-c Return middle line of a clef
-c
- character*1 clefq
-c if (clefq.eq.'t' .or. clefq.eq.'0') then
-c ncmidf = 35
-c else if (clefq.eq.'s' .or. clefq.eq.'1') then
-c ncmidf = 33
-c else if (clefq.eq.'m' .or. clefq.eq.'2') then
-c ncmidf = 31
-c else if (clefq.eq.'a' .or. clefq.eq.'3') then
-c ncmidf = 29
-c else if (clefq.eq.'n' .or. clefq.eq.'4') then
-c ncmidf = 27
-c else if (clefq.eq.'r' .or. clefq.eq.'5') then
-c ncmidf = 25
-c else if (clefq.eq.'f' .or. clefq.eq.'7') then
-c ncmidf = 37
-c else
-c ncmidf = 23
-c end if
- ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2
- return
- end
- subroutine newvoice(jv,clefq,change)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- character*1 ulfbq,clefq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical change,autofbon
- nvmx(jv) = 1
- ivmx(jv,1) = jv
- itsofar(jv) = 0
- nnl(jv) = 0
- nfb(jv) = 0
- if (firstgulp .or. change) then
- ncmidcc(jv,1) = ncmidf(clefq)
- else
- ncmidcc(jv,1) = ncmidcc(jv,ncc(jv))
- end if
- tcc(jv,1) = 0.
- ncc(jv) = 1
- nudoff(jv) = 0
- ndotmv(jv) = 0
- do 5 j = 1 , 200
- irest(jv,j) = 0
- islur(jv,j) = 0
- ipl(jv,j) = 0
- nacc(jv,j) = 0
- iornq(jv,j) = 0
- mult(jv,j) = 0
- if (jv.le.2) isfig(jv,j) = .false.
-5 continue
- return
- end
- subroutine notefq(noteq,lnote,nolev,ncmid)
-c
-c Returns name of note level with octave transpositions, updates noctup.
-c
- common /comoct/ noctup
- character*8 noteq
- character*1 upcaseq,noteqt,chax
- nupfroma = mod(nolev+1,7)
- iname = 97+nupfroma
- ioctup = (nolev+1)/7-4
- noteqt = chax(iname)
- if (ncmid .eq. 23) noteqt = upcaseq(noteqt)
- if (ioctup .eq. noctup) then
- noteq = noteqt
- lnote = 1
-c
-c Must ALWAYS check if lnote=1 for use with functions requiring a blank
-c
- else if (ioctup .gt. noctup) then
-c
-c Raise octave. Encase in {}
-c
- write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1),
- * noteqt,'}'
- lnote = 3+ioctup-noctup
- noctup = ioctup
- else
-c
-c Lower octave
-c
- write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1),
- * noteqt,'}'
- lnote = 3+noctup-ioctup
- noctup = ioctup
- end if
- return
- end
- subroutine notex(notexq,lnote)
-c
-c Returns non-beamed full note name
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,ispoi,btest,even
- character*1 udq,udqq,chax
- character*4 dotq
- character*2 numq
- character*79 notexq
- character*8 noteq
- character*40 restq
- common /compoi/ ispoi
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figq
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- nodu = nodur(ivx,ip)
- if (.not.btest(irest(ivx,ip),0)) then
- udq = udqq(nole,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv)
- end if
-c
-c Check figure level
-c
-c if (figbass .and. isfig(ivx,ip)
-c * .and. .not.btest(irest(ivx,ip),0)) then
- if (figbass .and. .not.btest(irest(ivx,ip),0) .and.
- * ((ivx.eq.1.and.isfig(1,ip))
- * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then
- if (udq .eq. 'u' .or. nodu.ge.64) then
-c
-c Upper or no stem, fnole (in noleunits) set by notehead
-c
- fnole = nole
- else
-c
-c Lower stem, fnole set by bottom of stem
-c
- fnole = nole-stemlen
- end if
- zmin = fnole-ncmid(ivx,ip)+4
- if (ivx .eq. 1) then
- ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin))
- else
- ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin))
- end if
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- if (nodu .eq. 1) then
- notexq =sq//'cccc'//udq//noteq(1:lnoten)
- lnote = lnoten+6
- else if (nodu .eq. 2) then
- notexq =sq//'ccc'//udq//noteq(1:lnoten)
- lnote = lnoten+5
- else if (nodu .eq. 4) then
- notexq =sq//'cc'//udq//noteq(1:lnoten)
- lnote = lnoten+4
- else if (nodu .eq. 8) then
- notexq =sq//'c'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 16) then
- notexq =sq//'q'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 32) then
- notexq =sq//'h'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 64) then
- notexq =sq//'wh'//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 128) then
-c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk'
-c lnote = lnoten+10
- notexq =sq//'breve'//noteq(1:lnoten)
- lnote = lnoten+6
- else
- dotq = 'p'
- ldot = 1
- if (btest(iornq(ivx,ip),13)) then
-c
-c Dotted note with ')' ornament
-c
- dotq='m'
- else if (btest(islur(ivx,ip),3)) then
-c
-c Double dot
-c
- dotq = 'pp'
- ldot = 2
- end if
- if (nodu .ge. 192) then
- notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+6+ldot
- else if (nodu .ge. 96) then
- notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 48) then
- notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 24) then
- notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 12) then
- notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 6) then
- notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+4+ldot
- ispoi = .true.
- else
- notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+5+ldot
- ispoi = .true.
- end if
- if (dotq(1:1) .eq. 'm') then
-c
-c Need another call to the note, in case the first one has octave shifts
-c
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- end if
- else if (btest(islur(ivx,ip),29)) then
-c
-c Blank rest
-c
- notexq = sq//'sk'
- lnote = 3
- else
-c
-c Non-blank rest
-c
- lnote = 0
- nole = mod(nole+20,100)-20
-c
-c Kluge to get pause symbol for rp:
-c
- if (btest(islur(ivx,ip),19)) nodu = 64
- if (nodu .le. 28) then
-c
-c Normal rest < or = double-dotted quarter
-c
- lrest = 3
- if (nodu .gt. 14) then
- restq =sq//'qp'
- else if (nodu .gt. 7) then
- restq =sq//'ds'
- else if (nodu .gt. 3) then
- restq =sq//'qs'
- else if (nodu .gt. 1) then
- restq =sq//'hs'
- else
- restq =sq//'qqs'
- lrest = 4
- end if
-c if (2**log2(nodu) .ne. nodu) then
-cc
-cc One or two dots on rest
-cc
-c restq = restq(1:3)//'p'
-c lrest = 4
-c if (2*nodu .gt. 3*2**log2(nodu)) then
-cc
-cc Double dotted rest
-cc
-c restq = restq(1:4)//'p'
-c lrest = 5
-c end if
-c end if
- notexq = restq
- lnote = lrest
-c
-c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc.
-c
- if (nole .ne. 0) then
- if (abs(nole) .lt. 10) then
- noteq = chax(48+abs(nole))
- lnoten = 1
- else
- write(noteq(1:2),'(i2)')abs(nole)
- lnoten = 2
- end if
- if (nole .gt. 0) then
- notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
- else
- notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
- end if
- lnote = 16+lnoten
-c if (2**log2(nodu) .ne. nodu) then
-cc
-cc Have dot in raised rest. must put in hbox!
-cc
-c notexq = notexq(1:lnote)//sq//'hbox{'
-c lnote = lnote+6
-c end if
- notexq = notexq(1:lnote)//restq(1:lrest)
- lnote = lnote+lrest
-c if (2**log2(nodu) .ne. nodu) then
-c notexq = notexq(1:lnote)//'}'
-c lnote = lnote+1
-c end if
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Deal with dots (on rests shorter than half rest)
-c
- restq = sq//'pt'
- lrest = 3
- if (2*nodu .gt. 3*2**log2(nodu)) then
- restq = sq//'ppt'
- lrest = 4
- end if
- nole = nole+4
- raisedot = 0
-c
-c Tweak dot positions for special cases
-c
- even = (mod(100+nole,2).eq.0)
-c if (.not.even.and.nodu.gt.8.and.
-c * (nole.lt.0.or.nole.gt.8)) then
- if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then
- raisedot = 1
- end if
- if (nole.ge.10 .or. nole.le.-1) then
- write(numq,'(i2)')nole
- restq = restq(1:lrest)//'{'//numq//'}'
- lrest = lrest+4
- else
- restq = restq(1:lrest)//chax(nole+48)
- lrest = lrest+1
- end if
- if (raisedot.gt.0) then
- restq = sq//'raise'//sq//'internote'//
- * sq//'hbox{'//restq(1:lrest)//'}'
- lrest = lrest+23
- end if
-
-
-
- notexq = restq(1:lrest)//notexq(1:lnote)
- lnote = lnote+lrest
- end if
- else
-c
-c Half rest or longer
-c
- if (nole .eq. 0) then
-c
-c Half or longer rest is not raised or lowered
-c
- if (nodu .le. 56) then
- notexq =sq//'hpause'
- lnote = 7
- else if (nodu .le. 112) then
- if (.not.btest(islur(ivx,ip),19) .or.
- * btest(irest(ivx,ip),25)) then
- notexq = sq//'pause'
- else
- notexq = sq//'pausc'
- end if
- lnote = 6
- else
- notexq =sq//'PAuse'
- lnote = 6
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Dotted rest, hpause or longer
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- if (2*nodu .gt. 3*2**log2(nodu)) then
-c
-c Double dotted long rest
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- end if
- else
-c
-c Raised or lowered half or whole rest
-c
- if (nodu .eq. 32) then
- notexq = sq//'lifthpause'
- lnote = 11
- else if (nodu .eq. 48) then
- notexq = sq//'lifthpausep'
- lnote = 12
- else if (nodu .eq. 56) then
- notexq = sq//'lifthpausepp'
- lnote = 13
- else if (nodu .eq. 64) then
- notexq = sq//'liftpause'
- lnote = 10
- else if (nodu .eq. 96) then
- notexq = sq//'liftpausep'
- lnote = 11
- else if (nodu .eq. 112) then
- notexq = sq//'liftpausepp'
- lnote = 12
- else if (nodu .eq. 128) then
- notexq = sq//'liftPAuse'
- lnote = 10
- else
-c
-c Assume dotted double whole rest
-c
- notexq = sq//'liftPAusep'
- lnote = 11
- end if
-c
-c Set up height spec
-c
- nole = sign(abs(nole)/2,nole)
- if (nole.le.9 .and. nole.ge.0) then
- noteq = chax(48+nole)
- lnoten = 1
- else
- noteq = '{'
- if (nole .ge. -9) then
- write(noteq(2:3),'(i2)')nole
- lnoten = 3
- else
- write(noteq(2:4),'(i3)')nole
- lnoten = 4
- end if
- noteq = noteq(1:lnoten)//'}'
- lnoten = lnoten+1
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- end if
- end if
- return
- end
- function ntindex(line,s2q,lenline)
-c
-c Returns index(line,s2q) if NOT in TeX string, 0 otherwise
-c
- character*(*) s2q,line
- character*1 chax
- logical intex
- ndxs2 = index(line,s2q)
- ndxbs = index(line,chax(92))
- if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
- ntindex = ndxs2
- else
-c
-c There are both bs and s2q, and bs is to the left of sq2. So check bs's to
-c right of first: End is '\ ', start is ' \'
-c
- len = lenstr(line,lenline)
- intex = .true.
- do 1 ic = ndxbs+1 , len
- if (ic .eq. ndxs2) then
- if (intex) then
- ntindex = 0
- ndxs2 = index(line(ic+1:len),s2q)+ic
- else
- ntindex = ndxs2
- return
- end if
- else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then
- intex = .false.
- else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92))
- * then
- intex = .true.
- end if
-1 continue
- end if
- return
- end
- subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote)
-c
-c This appends to notexq e.g. '\ibbbu1'
-c
- common /combbm/ isbbm
- logical isbbm
- character*79 notexq
- character*1 char1q,ulqq,chax
- character*4 tempq
- if (n .ge. 5) isbbm = .true.
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//chax(92)//char1q
- else
- notexq = chax(92)//char1q
- end if
- lnote = lnote+2
- do 3 im = 1 , n
- notexq = notexq(1:lnote)//'b'
- lnote = lnote+1
-3 continue
-c
-c add the number, 0 if 12
-c
-c 5/25/08 Allow >12
-c
-c call istring(mod(iv,12),tempq,len)
- if (iv .lt. 24) then
- call istring(iv,tempq,len)
- else if (iv .eq. 24) then
- tempq(1:1) = '0'
- len = 1
- else
- call printl('Sorry, too man open beams')
- call stop1()
- end if
- notexq = notexq(1:lnote)//ulqq//tempq(1:len)
- lnote = lnote+1+len
- return
- end
- function numclef(clefq)
-c
-c Returns the number to be used as argument of \setclef (for MusiXTeX only)
- character*1 clefq
-c if (ichar(clefq) .lt. 55) then
- if (ichar(clefq) .le. 55) then
- numclef = ichar(clefq)-48
- if (numclef .eq. 7) numclef = 9
- else
- numclef = index('tsmanrbxxf',clefq)-1
- end if
- return
- end
- subroutine outbar(i,jlast)
- character*1 chax
- nfmt = log10(i+.5)+2
- if (jlast+5+nfmt .lt. 80) then
- write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = jlast+5+nfmt
- else
- write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = 5+nfmt
- end if
- return
- end
- subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize)
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc cc
-cc Subroutine, combine with pmxb.for
-cc
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc
-cc Need to consider X spaces in xtuplets when getting poenom, and
-cc maybe fbar?
-cc mx06a
-cc ID numbers for voices when number of voices is reduced.
-cc
-cc mx03a
-cc account for new fracindent for new movements.
-cc
-cc Known changes since pmxa. Version 1.1b (see pmxb for longer list)
-cc
-cc Check ID codes for slurs.
-cc Version 1.24 still does not have details for spacing/positioning
-cc arpeggios if there are accidentals or shifted notes or crowded scores.
-cc Fix problem in 1.22 with arpeggios across multi-line staves
-cc Fix problem in 1.22 with flat key signatures
-cc Read setup data as strings
-cc Warning for octave designation plus +/-
-cc Don't pause for volta warning,
-cc Macros
-cc Correct fsyst to account for transposition and key changes.
-cc Check for nbars > nsyst
-cc
-ccccccccccccccccccccccccccccccccccc
- parameter (nm=24,nkb=3999,nks=125,maxblks=4000)
- logical loop,usefig,isfirst,optimize
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- integer nn(nm),nodur(nm,200),ivxo(600),ipo(600),
- * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600)
- character*128 lnholdq
- character*44 basenameq
- logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt,
- * stickyS
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr,
- * shifton,barend
- common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml,
- * nodur,lenbar,iccount,nbars,itsofar,nib,nn,
- * rest,lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- common /comeon/ eonk,ewmxk
- logical mrecord,mplay,endmac,gotclef,cstuplet
- logical novshrinktop,upslur,fontslur,WrotePsslurDefaults
- common /comnvst/ novshrinktop,cstuplte
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- data wtimesig,wclef,wkeysig
- * / 0.72 , 0.8 , 0.28 /
- whead20 = 0.3
- if (.not.optimize) then
- print*
- print*,'Starting first PMX pass'
- write(15,'(a)') ' Starting first PMX pass'
- end if
- if (isfirst) then
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') 0
- close(19)
- end if
- if (.not.optimize) jprntb = 81
- macuse = 0
- ornrpt = .false.
- stickyS = .false.
- mrecord = .false.
- mplay = .false.
- lastchar = .false.
- novshrinktop = .false.
- cstuplet = .false.
- fontslur = .true.
- isligfont = .false.
- fulltrans = .false.
- do 42 ibarcnt = 1 , nkb
- udsp(ibarcnt) = 0.
- wminnh(ibarcnt) = -1.
-42 continue
-c
-c Initialize input buffer
-c
- lenbuf0 = ipbuf
- ipbuf = 0
- ilbuf = 1
- call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb)
-c
-c Set up list of instrument numbers (iv)
-c
- ivnow = 0
- do 13 instnow = 1 , noinst
- do 14 iscount = 1 , nsperi(instnow)
- ivnow = ivnow+1
- instno(ivnow) = instnow
-14 continue
-13 continue
-c
-c Save initial meter for midi
-c
- if (.not.isfirst .and. npages.eq.0) then
- print*,'Sorry, must have npages>0 for optimization.'
- call stop1()
- end if
- nsyout = nsyst
-c
-c isig1 will be changed in getnote if there is a transposition
-c
- isig1 = newkey(1)
- if (npages .gt. nsyst) then
- call printl('npages > nsyst in input. Please fix the input.')
- call stop1()
- end if
-c
-c fbar = afterruleskip/elemskip
-c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt
-c
- fbar = 1.
- wheadpt = whead20*musize
- ifig = 0
- usefig = .true.
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbr1 = lenmult*mtrnuml*lenbeat
- lenbr0 = nint(lenmult*xmtrnum0*lenbeat)
- mtrnuml = 0
- if (lenbr0 .ne. 0) then
- ibaroff = 1
- lenbar = lenbr0
- else
- ibaroff = 0
- lenbar = lenbr1
- end if
- ibarcnt = 0
- nptr(1) = 1
- iccount = 128
- nmovbrk = 0
- nflb = 0
- nfpb = 0
- ipagfpb(0) = 1
- isysfpb(0) = 1
- ibarflb(0) = 1
- isysflb(0) = 1
- nistaff(0) = nv-1
-c
-c Check for pmx.mod
-c
- linesinpmxmod = 0
-c line1pmxmod = ilbuf
- call getpmxmod(.true.,' ')
- if (.not.isfirst .and. linesinpmxmod .gt. 0) then
- print*,'Sorry, cannot optimize if there is a pmx.mod file'
- call stop1()
- end if
-c
-c Initialize for loop over lines
-c
- nkeys = 1
- ibrkch(1) = 1
- mbrestsav = 0
- shifton = .false.
- firstline = .true.
- newmeter = .false.
- ihead = 0
- isheadr = .false.
- gotclef = .false.
- idsig = 0
- iddot = 0
- fintstf = -1.
- gintstf = 1.0
- listcresc = 0
- listdecresc = 0
-30 loop = .true.
- iskchb = .false.
- issegno = .false.
- nbars = 0
- ibarmbr = 0
-3 do 4 iv = 1 , nv
- nvmx(iv) = 1
- ivmx(iv,1) = iv
- itsofar(iv) = 0
- nnl(iv) = 0
- do 5 j = 1 , 200
- rest(iv,j) = .false.
- nacc(iv,j) = 0.
-5 continue
-4 continue
- iv = 1
- ivx = 1
- fbon = .false.
- barend = .false.
- isvolt = .false.
-2 if (loop) then
-c
-c Within this short loop, nv voices are filled up for the duration of a block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nodur(..),rest(..). nnl will later be
-c increased and things slid around as accidental skips are added.
-c
- call g1etnote(loop,ifig,optimize,fulltrans)
- if (lastchar) go to 20
- go to 2
- end if
- if (mbrestsav .gt. 0) then
- call printl(' ')
- call printl(
- * 'You must enter the same multibar rest in ALL parts')
- call stop1()
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
-c
-c The following is just a signal to start a new bar when cataloging spaces
-c for catspace(...)
-c
- nptr(ibarcnt+1) = nptr(ibarcnt)
- newmb(ibarcnt) = .false.
- if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true.
-c
-c Above is only for spacing calcs later on. Remember new meter can only occur
-c at START of a new input line (ibar = 1)
-c
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb)
- else
- if (.not.optimize) then
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- jprntb = 0
- end if
- ibaroff = ibaroff-mbrest+1
- end if
- if (firstline .and. lenbr0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenbr0
- else
- lenbar = lenbr1
- end if
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- rest(ivx,ip) = rest(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
-12 continue
-11 continue
- end if
- do 67 iv = 1 , nv
- do 67 kv = 1 , nvmx(iv)
- ioff= 0
- if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1)
-67 continue
- call makeabar()
- elsk(ibarcnt) = elskb+fbar
-10 continue
- newmeter = .false.
- firstline = .false.
- go to 30
-20 continue
-c
-c Vertical analysis.
-c
- if (npages .eq. 0) then
- if (nsyst .eq. 0) then
- print*,'When npages=0, must set nsyst=bars/syst, not 0'
- call stop1()
- end if
- nsyst = (ibarcnt-1)/nsyst+1
- if (nv .eq. 1) then
- nsystpp = 12
- else if (nv .eq. 2) then
- nsystpp = 7
- else if (nv .eq. 3) then
- nsystpp = 5
- else if (nv .eq. 4) then
- nsystpp = 3
- else if (nv .le. 7) then
- nsystpp = 2
- else
- nsystpp = 1
- end if
- npages = (nsyst-1)/nsystpp+1
- end if
-c
-c Check nsyst vs ibarcnt
-c
- if (nsyst .gt. ibarcnt) then
- print*
- print*,'nsyst,ibarcnt:',nsyst,ibarcnt
- print*,'There are more systems than bars.'
- write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt
- write(15,'(a)')' There are more systems than bars.'
- call stop1()
- end if
-c
-c Set up dummy forced line & page breaks after last real one
-c
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+1
- isysflb(nflb) = nsyst+1
- nfpb = nfpb+1
- ipagfpb(nfpb) = npages+1
- isysfpb(nfpb) = nsyst+1
- heightil = ptheight*4./musize
- open(12,status='SCRATCH')
- write(12,'(a)')basenameq(1:lbase)
- write(12,*)lbase
-c
-c Pass to pmxb the initial signature, including effect of transposition.
-c
- write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait,
- * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1
- write(12,*)npages,widthpt,ptheight,nsyst
- iflbnow = -1
- isysb4 = 0
- do 8 ifpb = 1 , nfpb
-c
-c Each time thru this loop is like a single score with several pages
-c
- npages = ipagfpb(ifpb)-ipagfpb(ifpb-1)
- nsyst = isysfpb(ifpb)-isysfpb(ifpb-1)
- nomnsystp = (nsyst-1)/npages+1
- nshort = nomnsystp*npages-nsyst
- do 7 ipage = 1 , npages
- nsystp = nomnsystp
- if (ipage .le. nshort) nsystp = nsystp-1
-c
-c Last system number on this page:
- isysendpg = isysb4+nsystp
- nintpg = 0
- do 15 isy = isysb4+1, isysendpg
- if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1
- nintpg = nintpg+nistaff(iflbnow)
-15 continue
- xilfrac = 0.
- xiltxt = 0.
- if (ipage.eq.1 .and. ihead.gt.0) then
-c
-c Needn't zero out ihead after printing titles if we only allow titles at top?
-c
- if (iand(ihead,1) .eq. 1) then
- xiltxt = xiltxt+hgtin*4/musize
- xilfrac = xilfrac+etait
- end if
- if (iand(ihead,2) .eq. 2) then
- xiltxt = xiltxt+hgtti*4/musize
- xilfrac = xilfrac+etatc
- end if
- if (iand(ihead,4) .eq. 4) then
- xiltxt = xiltxt+hgtco*4/musize
- xilfrac = xilfrac+etacs1
- else
-c
-c Use double the title-composer space if there is no composer
-c
- xilfrac = xilfrac+etatc
- end if
- end if
- D = xilfrac+nsystp-1+etatop+etabot
-c C = nsystp*(nv-1)
- C = nintpg
-c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn
- xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn
- if (bottreb) xN = xN-(nsystp-1)*xilbtc
- if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr
- if (ifig .eq. 1) then
- xN = xN - nsystp*xilfig
- end if
- glueil = (xN-b*C)/(D+a*C)
- omegaG = (b*D+a*xN)/(D+a*C)
-c
-c G = \interlines between systems
-c omega*G = \interlines between staves of the same system
-c \interstaff = 4+omega*G
-c C = total number of interstaff spaces in the page
-c D = omega-indep factors for scalable height = nsy-1 (intersystem glue)
-c + etatop + etabot + etatxt +
-c N = scaleable height (\interlignes) = height - htext - staff heights - xil
-c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles
-c + (nsy-1)*xiltcb for treble clef bottoms
-c + nsy*xilfig for figures
-c G = N/(D + omega * C) = glueil, (1)
-c But (empirically) omega*G = a*G + b (2)
-c with a=1.071 and b=2.714
-c Solving (1) and (2) gives
-c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C)
-c Pass to pmxb omega*G (=\interstaff-4)
-c (etatop,bot,it,tc,cx)*G as inputs to \titles
-c
-c glueil = (heightil-xiltxt-nsystp*(xil+4*nv))
-c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac)
-c xnsttop = glueil*etatop
-c xintstaff = 4+gfact*glueil
-c
-c Only the first page will get local adjustment now if needed, others in pmxb
-c
- if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then
- facins = fintstf
- fintstf = -1.
- else
-c
-c gintstf = 1.0 by default, but may be changed with AI<x>
-c
- facins = gintstf
- end if
- write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4)
- ihead = 0
- isheadr = .false.
- isysb4 = isysendpg
-7 continue
-8 continue
-c
-c Done with vertical, now do horizontals
-c
- celsk(1) = elsk(1)
- do 21 ibar = 2 , ibarcnt
- celsk(ibar) = celsk(ibar-1)+elsk(ibar)
-21 continue
- lastbar(0) = 0
- ibar1 = 1
- wmins = -1.
- iflb = 1
- imovbrk = 0
- ikey = 1
-c
-c Return nsyst to its *total* value
-c
- nsyst = isysfpb(nfpb)-1
- do 22 isyst = 1 , nsyst
- if (isyst .eq. isysflb(iflb)) iflb = iflb+1
- if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then
- if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1
- end if
- ibarb4 = lastbar(isyst-1)
- if (isyst .eq. 1) then
- if (isfirst) elsstarg = celsk(ibarflb(1)-1)/
- * (isysflb(1)-1-fracindent)*(1-fracindent)
- celskb4 = 0.
- else
- celskb4 = celsk(ibarb4)
-c
-c Must dimension isysmb(0:*) just so I can execute this test!
-c
- if (isfirst) then
- if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then
-c
-c First syst after forced line break. There may be indentation.
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst-fracsys(imovbrk))
- * *(1-fracsys(imovbrk))
- else
-c
-c There is no indentation to deal with
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst)
- end if
- end if
- end if
- if (isfirst) then
- diff1 = abs(elsstarg-elsk(ibarb4+1))
- do 23 ibar = ibarb4+2 , ibarcnt
- diff = elsstarg-(celsk(ibar)-celskb4)
- if (abs(diff) .ge. diff1) go to 24
- diff1 = abs(diff)
-23 continue
-24 ibar = ibar-1
- lastbar(isyst) = ibar
- nbarss(isyst) = ibar-ibarb4
- else
-c
-c nbarss is given as an input, must compute lastbar and ibar
-c
- lastbar(isyst) = nbarss(isyst)+ibarb4
- ibar = lastbar(isyst)
- end if
-c
-c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's.
-c
- elss(isyst) = celsk(ibar)-celskb4
- write(12,'(i5)')lastbar(isyst-1)+1
-c
-c Transposed sigs are isig1, newkey(2,3,...).
-c
- if (ikey .eq. 1) then
- key1 = isig1
- else
- key1 = newkey(ikey)
- end if
- fsyst = wclef+abs(key1)*wkeysig+2./musize
- xelsk = 0.
-1 if (ikey.lt.nkeys) then
- if (ibrkch(ikey+1).le.lastbar(isyst)) then
-c
-c Add space for all key changes
-c
- ikey = ikey+1
- key2 = newkey(ikey)
- naccs = max(abs(key2-key1),max(abs(key1),abs(key2)))
- fsyst = fsyst+naccs*wkeysig
-c
-c Account for afterruleskips (fbar)
-c
- xelsk = xelsk+fbar/2
- if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey))
- * xelsk = xelsk-1.
- key1 = key2
- go to 1
- end if
- end if
-c
-c Add extra fixed space for double bar
-c
- if (isyst .eq. nsyst) then
- fsyst = fsyst+4.5/musize
- end if
-c
-c Add extra fixed space for initial time signature
-c
- if (isyst .eq. 1) then
- fsyst = fsyst+wtimesig
- end if
-c
-c Add extra fixed space for time signature changes & user-defined spaces
-c
- do 26 ibars = ibarb4+1 , lastbar(isyst)
- if (newmb(ibars)) fsyst = fsyst+wtimesig
- fsyst = fsyst+udsp(ibars)/musize
-26 continue
- if (isyst .eq. 1) then
- wdpt = widthpt*(1-fracindent)
- else
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- wdpt = widthpt*(1-fracsys(imovbrk))
- else
- wdpt = widthpt
- end if
- end if
- wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst)
-c
-c Checks for min spacing
-c Get min allowable space
-c
- dtmin = 1000.
- do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1
- dtmin = min(dtmin,tnminb(ibar))
- if (wminnh(ibar).ge.0.) wmins = wminnh(ibar)
-45 continue
- if (wmins .lt. 0) wmins = 0.3
- wminpt = (1+wmins)*0.3*musize
-c
-c Find max duration & # of notes for this system
-c
- dtmax = 0.
- nns = 0
- do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- dtmax = max(dtmax,durb(iptr))
- nns = nns + nnpd(iptr)
-43 continue
- elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk)
- if (elmin0 .ge. wminpt) then
-c
-c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb;
-c there is no need to "flatten"
-c
- sumelsk = elss(isyst)-fbar*nbarss(isyst)
- eonk = 0.
- ewmxk = 1.
- else
- elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns)
- if (elmin1 .le. wminpt) then
-c print*
-c print*,'In system #',isyst,' cannot meet min. space rqmt'
-c write(15,'(/a,i5,a)')
-c * 'In system #',isyst,' cannot meet min. space rqmt'
- eonk = 0.9
- else
-c
-c Find eonk by Newton method
-c
-c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0))
- call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1,
- * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax,
- * (wminpt-elmin0)/(elmin1-elmin0))
- eonk = min(.9,eonk)
- end if
- ewmxk = f1eon(dtmax)**eonk
-c
-c Recompute poenom!
-c
- sumelsk = 0
- do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- sumelsk = sumelsk
- * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr))
-44 continue
- end if
- poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk)
-c
-c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0
-c
- if (isyst .gt. 0) then
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- fracindent = fracsys(imovbrk)
- else
- fracindent = 0.
- end if
- end if
- write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst),
- * sumelsk,fsyst,fracindent,eonk,ewmxk
- ibar1 = ibar1+nbarss(isyst)
-22 continue
- rewind(12)
- open(13,status='SCRATCH')
- write(13,'(i5)')ifig
- rewind(13)
- ilbuf = 1
- ipbuf = 0
- if (.not.optimize) then
- write(*,'(/,a)')' Done with first pass'
- print*
- write(15,'(/,a)')' Done with first pass'
- write(15,'()')
- end if
-c
-c Following syntax is needed since pmxa is called with literal argument .false.
-c
- if (isfirst) isfirst = .false.
- return
- end
- subroutine pmxb(inlast,poevec,ncalls,optimize)
-cccccccccccccccccccccccccc
-cc
-cc To Do
-cc
-cc Resolve disagreement in final poe for 1st system, compared with *.mx2
-cc Shift slurs on right- or left-shifted main notes (2/7/99)
-cc Various end-of-input-block repeat problems (ick142.pmx).
-cc Force multiplicity for un-beamed xtups.
-cc Clef change at end of piece
-cc Global "A" option to maximize "X" at a given time tick.
-cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted
-cc note. See trubl18.pmx
-cc Tab character as space.
-cc Clef interference with second line of music.
-cc Add space for interferences between *different* lines of music?
-cc Shift arpeggios, both automatic and manual.
-cc Different musicsize for different instruments.
-cc Spacing checks for accid's on left-shifted chord notes
-cc Spacing checks for double dots
-cc Allow forced line breaks w/o setting nsyst.
-cc Cresc-Decresc. (Enhance MusiXTeX first?)
-cc Dynamic Marks.
-cc Bug with Voltas at line end (MusiXTeX problem?).
-cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx
-cc Stem-end slurs.
-cc Allow units in indentation.
-cc Make inline TeX more context sensitive.
-cc Werner's 4/2/98 problem with "o?"
-cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong.
-cc converts e.g. "r2db" into "r2d", which might be wrong.
-cc Werner's generalsignature problem with Key change and new transposition.
-cc (wibug8.pmx)
-cc Unequal xtuplets
-cc Print both sets of bar #'s in tex file.
-cc Make barlines invisible \def\xbar{\empty} , fix fbar.
-cc Auto-tie slurs 'At'
-cc Forced line break anywhere (e.g. at a mid-bar repeat).
-cc Clef change at very start of file.
-cc Tighten test for M as macro terminator.
-cc Fix title so not separate limit on author length + composer length.
-cc Arpeggios in xtups.
-cc
-cc mx10b
-cc Option for instrument name at top center. Last item in P command:
-cc P[n]c text is instrument name (use in parts)
-cc P[n]cstuff text is stuff (up to 1st blank)
-cc P[n]c"stuff with spaces" text is stuff with spaces
-cc
-cc Post version 1.43
-cc Reduced space rqmt for multiplicity-0 graces (no flag)
-cc Removed last sepsym in centered whole-bar rests, fixes volta height bug.
-cc
-cc Version 1.43
-cc Fix spacing for end-of-line signature change.
-cc Adjust left-shift of grace group for shifted accidentals.
-cc Put in extra space for left-shifted accidentals.
-cc Fix bug with dot-shift before accid-shift on chord note.
-cc Space-check for right-shifted main notes.
-cc Enable forcing stem direction of single notes in non-beamed xtups.
-cc Disallow clef change after last note before end of input block (pmxa)
-cc Print meter change before page break
-cc increase length of strings for \titles macro
-cc version 1.42
-cc Loosen up input syntax for "X" commands. Subroutine getx()
-cc "B" and "P" in "X" commands
-cc mx09b
-cc Allow multiple rests at start of xtup
-cc Add 64th rest
-cc Fix xtup numbers over rests. (subroutine levrn)
-cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g.
-cc c za / ( c a ...
-cc Allow double dots to be shifted.
-cc Fix spacing with double dotted notes; permit splitting small note.
-cc Fix \dotted printout so it works with old compiler
-cc mx08b
-cc Automatic spaces if needed for shifted accidentals.
-cc Some Dynamics
-cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc)
-cc version 1.41
-cc Allow ":" as last char of path name
-cc Dotted slurs "sb"
-cc Continue bar numbering at movement break "L[integer]Mc"
-cc mx07b
-cc Whole-bar rests with double lines of music. Fixed all options ?
-cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number].
-cc Option to suppress centering full-bar rests. "o"
-cc mx06b
-cc Shift accid on left-shifted chord note.
-cc Rest as first note of xtup.
-cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt
-cc Allow Rb for single bar at movemnet break or end of piece. (islur(25))
-cc Change # of inst at a movement break. noinst is total # and must be used
-cc in 1st movement. ninow is current. nspern(1,...,ninow) is current
-cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to
-cc reprint names in parindent at a movement break. Default is .false.
-cc unless ninow changes, then .true. But can force either with r+/- as
-cc option in 'M'
-cc mx04b
-cc Double-dotted notes, separate+beamed, main+chord, still no extra space.
-cc ??? Don't shift slur ends on whole notes.
-cc (pmxa) Write line number of error in pmxaerr.dat
-cc mx02b
-cc Admit "RD" before "/" (search for "rptfq2:" )
-cc In doslur, for multi-line staves, single notes, check forced stem dir'n
-cc before setting stemup (used to set horiz offset).
-ccccccccccccccccccccccccccccccc
- parameter (nm=24,nks=125,mv=24576,maxblks=4000)
-c
-c FYI /all/ differs in appearance in function ncmid
-c
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
-ccccccccccccc
-cc islur cc
-ccccccccccccc
-c bit meaning
-c 0 slur activity on this note
-c 1 t-slur here.
-c 2 force 0-slope beam starting on this note
-c 3 Double dotted note!
-c 4 grace before main note
-c 5 left repeat
-c 6 right repeat
-c 7 start Volta
-c 8 doublebar
-c 9 end Volta
-c 10 on=>endvoltabox
-c 11 on=>clefchange
-c 12-14 0=>treble, ... , 6=>bass
-c 15 on=> start new block for clef change (maybe diff. voice)
-c 16 literal TeX string
-c 17 1=up, 0=down stem for single note (override) See bit 30!
-c 18 if on, prohibit beaming
-c 19 if on, full bar rest as pause
-c 20 Beam multiplicity down-up
-c 21 Forced multiplicity for any beam including xtups
-c 22-24 Value of forced multiplicity
-c 25 single barline at movement break
-c 26 doubleBAR (see bits 5,6,8)
-c 27-28 Forced beam fine-tune height (1 to 3)
-c 29 Blank rest
-c 30 If on, get stem dir'n from bit 17
-c 31 If on, suppress printing number with xtuplet starting here
-ccccccccccccc
-cc ipl cc
-ccccccccccccc
-cc 0-7 Location in list [0,200]
-c 0-7 Unused
-c 8 left offset main note one headwidth
-c 9 right offset main note one headwidth
-c 10 chord present?
-c 11-16 Forced beam height adjustment (-30 to +30)
-c 17-22 Forced beam slope adjustment (-30 to +30)
-c 23-26 Slur index for Way-after grace. Inserted when slur is started.
-cc 27 Unused?
-c 27 5th bit for slur index for Way-after grace (100712)
-c 28 key change: only in voice 1
-c 29 Grace after main note. (Type A)
-c 30 In forced beam. Signals need to check beam heights
-c 31 Grace way after main note. (stretch to next note, type W)
-ccccccccccccc
-cc iornq cc
-ccccccccccccc
-c 0 Ornament "(". Was user-defined horizontal slur shift on this note
-c until 9/24/97; changed that to irest(21)
-c 1-13 stmgx+Tupf._)
-c 14 Down fermata, was F
-c 15 Trill w/o "tr", was U
-c 16-18 Editorial s,f,n
-c 19-20 >^
-c 21 "?" for editorial accid, w/ or w/o s,f,n
-c 22 Set if ihornb governs ornament height. Same in icrdorn.
-c 23 Set in getorn if ANY note at time of this main note has ornament.
-c This is ONLY used in beamstrt to signal whether to do more
-c tests for whether ihornb is needed. (ihornb is only needed
-c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note)
-c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm.
-c 24 Slur on after or way-after grace. Use as signal to START slur.
-c 25 Tweak orn ht. Same in icrdorn for chord note
-c 26 Insert user-defined space before this note (was 22)
-c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord
-c 28 caesura or breath
-c 29 blank barline (must be iv=1) (would have used islur but no room)
-c 30 "Look-left" option for keyboard rest
-c 31 Set if any note (main or chord) has cautionary accid, for space checks
-ccccccccccccc
-cc irest cc
-ccccccccccccc
-c 0 rest=1, no rest = 0
-c 1 There will be a vertical shift for number of this xtup
-c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n'
-c 7 There is a horizontal shift for xtup number
-c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5
-c 14 Flip up/down-ness of xtup number
-c 15 Single-voice, single note shift X(...)[p]S
-c 16 Start single-voice, multinote shift with this note X(...)[p]:
-c 17 End single-voice, multinote shift after this note. Enter symbol
-c after note. X:
-c 18 User-defined hardspace after last note of bar, *after* this note.
-c Value still stored in udoff(ivx,nudoff(ivx)), not with other
-c hardspaces in udsp, to avoid confusion with time checks.
-c 19 Move the dot. Data stored in ndotmv,updot,rtdot
-c 20 Set if right-shifted main or chord note here. Use for space checks.
-c 21 User-defined hardspace in xtup
-c 22 User-defined slur shift horizontal slur shift.
-c 23 Set on last note before staff-jumping a beam.
-c 24 Set on first note after staff-jumping a beam
-c 25 Suppress rest centering. "ro"
-c 26 Dynamic on this note
-c 27 Set if left-shifted main or chord note here. Use for space checks.
-c 28 Set if xtup starts on this note.
-c 29 Set on lowest-voice note at same time as 1st note after jump-beam.
-c 30 Set on note after end of jump-beam segment, to force new note group
-c 31 Flag for cautionary accidental
-ccccccccccccc
-cc nacc cc
-ccccccccccccc
-c 0-1 0=no accid, 1=fl, 2=sh, 3=na
-c 2 double
-c 3 big
-c 4-9 vertshift-32
-c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32)
-c 17 Midi-only accidental
-c 18 2:1 xtup
-c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note.
-c 20 Set on last note of each seg except last seg of single-slope beam.
-c 21 Set on 1st note of each seg except 1st seg of single-slope beam.
-c 22-26 If .ne.0, printed xtup number for xtup starting on this note.
-c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase
-c multiplicity by 1
-c 28 Set on main note of chord if accidentals are ordered.
-c 29 Tag for chordal accidental shift...means add to autoshifts.
-c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted.
-c If upstem|downstem, main is upper|lower member of 2nd
-c Action is to interchange pitches only when notes are placed.
-ccccccccccccc
-cc mult cc
-ccccccccccccc
-c 0-3 Multiplicity+8 (mult= # of flags)
-c 4 Set if slope adjustment for xtup bracket
-c 5-9 16+slope adjustment
-c 27 Stemlength override
-c 28-30 New stem length.
-ccccccccccccc
-cc isdat1 cc
-ccccccccccccc
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-ccccccccccccc
-cc isdat2 cc
-ccccccccccccc
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted slur
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-ccccccccccccc
-cc isdat3 cc
-ccccccccccccc
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-ccccccccccccc
-cc isdat4 cc Set these all at turn-on using s option
-ccccccccccccc
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-ccccccccccccc
-c icrdat c
-ccccccccccccc
-c 0-7 ip within voice
-c 8-11 ivx (together with 28th bit)
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Flag for cautionary accidental on chord note
-ccccccccccccc
-c icrdot c:
-ccccccccccccc
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
-cccccccccccccccccccccccccccccccc
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*10 figq
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,
- * isfig,rptnd1,rptprev
- logical loop,lastchar,slint,svolta,evolta,onvolt,
- * cwrest(nm),islast,inlast,optimize
- integer istop(80),numbms(nm),istart(80)
- real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks),
- * tstart(80),squez(80)
- character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq
- character*79 notexq,inameq
- character*40 pathnameq
- character*44 basenameq
- character*24 fmtq
- character*20 voltxtq
- character*120 instrq,titleq,compoq
- common /comlast/ islast,usevshrink
- logical usevshrink,stickyS,OptLineBreakTies,autofbon
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /comstart/ facmtr
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /combeam/ ibmtyp
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comas3/ ask(2500),iask,topmods
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2,
- * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq,lnholdq
- logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,
- * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb,
- * btest,sluron,setis,nobar1
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /compoi/ ispoi
- common /combc/ bcspec
- common /comeon/ eonk,ewmxk
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comhsp/ hpttot(176)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /commus/ musize,whead20
- common /comtol/ tol
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize,
- * ismbr,putmbr
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comcb/ nbc,ibcdata(36)
- common /comclefq/ clefq
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /combibarcnt/ ibarcnt
- if (.not.optimize) then
- print*
- print*,'Starting second PMX pass'
- print*
- write(15,'(a)')'Starting second PMX pass'
- end if
- ncalls = ncalls+1
- islast = inlast
- macuse = 0
- isyscnt = 0
- stemmax = 8.2
- stemmin = 3.9
- stemlen = 6.0
- sq = chax(92)
- bcspec = .true.
- topmods = .false.
- ismbr = .false.
- read(12,'(a)')basenameq
- read(12,*)lbase
- read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop,
- * etabot,inbothd,inhnoh,isig
- ilbuf = 1
- ipbuf = 0
- call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,
- * npages,nsyst,musicsize,fracindent,istype0,inameq,
- * clefq,sepsymq,pathnameq,lpath,isig0)
- if (ismidi) then
-c
-c Initial key signature and meter for pickup bar
-c
- call midievent('k',isig,0)
- if (xmtrnum0 .gt. tol) then
-c
-c We have a pickup. Some tricky stuff to get a meter:
-c
- xntrial = xmtrnum0
- do 5 ip2 = 0 , 5
- if (abs(mod(xntrial,1.)) .lt. tol) go to 6
- xntrial = xntrial*2
-5 continue
- print*,'Problem finding meter for pickup bar'
- xntrial = 1.
- ip2 = 0
-6 continue
- call midievent('m',nint(xntrial),2**ip2*mtrdenl)
- else
-c
-c No pickup, enter the starting meter
-c
- call midievent('m',mtrnuml,mtrdenl)
- end if
- end if
-c
-c Set musicsize from value passed in common, due to possible reset by S[n]m16
-c
- musicsize = musize
- read(12,*)npages,widthpt,height,nsyst,
- * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
-c
-c If default width ever changes, must adjust this stmt.
-c
- slfac1 = 0.00569*524./widthpt
- figbass = .false.
- read(13,*)ifig
- if (ifig .eq. 1) then
- figbass = .true.
- open(14,status='SCRATCH')
- write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq//
- * 'sysno by 1'//sq//'ifcase'//sq//'sysno%'
- end if
- lastchar = .false.
- ibcoff = 0
- if (xmtrnum0 .gt. 0.) ibcoff = -1
- open(11,status='SCRATCH')
-c
-c vshrink for the first page is calculated in topfile,
-c and if true set interstaff=10. vshrink affects Titles.
-c Must also save vshrink for page ending.
-c
- call topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur)
-c
-c ninow is working value of # of instruments. noinst is max #, and # at start.
-c
- ninow = noinst
-c
-c Save original printed meter in case movement breaks
-c
- movnmp = mtrnmp
- movdnp = mtrdnp
-c
- if (islast .and. figbass .and. musicsize.eq.16)
- * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%'
-c
- if (islast .and. isligfont) then
- if (musicsize .eq. 16) then
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%'
- else
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%'
- end if
- end if
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenb1 = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenb1 = lenb1*2
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- lenb0 = nint(xmtrnum0*lenbeat)
- if (mtrdenl .eq. 2) lenb0 = lenb0*2
- if (lenb0 .ne. 0) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1'
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
-c
-c Initialize full-program variables
-c
- fixednew = 0.
- scaldold = 0.
- fintstf = -1.
- gintstf = 1.
- nasksys = 0
- ibarcnt = 0
- iline = 0
- movbrk = 0
- isystpg = 0
- ipage = 1
- iccount = 128
- iask = 0
- nhstot = 0
- nb = 1
- if (.not.optimize) jprntb = 81
- idsig = 0
-c
-c Next 5 are raise-barno parameters. irzbnd is integer part of default level.
-c
- irzbnd = 3
- if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4
- is1n1 = 0
- isnx = 0
- SlurCurve = 0.
-c
-c 111109 Made global rather than per gulp
-c
- ndyn = 0
- ispoi = .false.
- slint = .false.
- lrptpend = .false.
- rptnd1 = .false.
- rptfq2 = 'E'
- rptprev = .false.
- onvolt = .false.
- flgndb = .false.
- fbon = .false.
- shifton = .false.
- ornrpt = .false.
- setis = .false.
- lowdot = .false.
- rename = .false.
- nobar1 = .false.
- equalize = .false.
- usevshrink = .true.
- WrotePsslurDefaults = .false.
- OptLineBreakTies = .false.
- HeaderSpecial = .false.
-c
-c vshrink is initialized in topfile
-c
- stickyS = .false.
-c
-c ixrest = 1 or 2 if xtup has started with a rest
-c
- do 1 ivx = 1 , nm
- ixrest(ivx) = 0
- fullsize(ivx) = 1.
-c
-c Set legacy note level to middle c as default
-c
- ndlev(ivx,1) = 29
- ndlev(ivx,2) = 29
-1 continue
- npreslur = 0
- nhssys = 0
- listslur = 0
- do 31 i = 1 , 202
- isdat1(i) = 0
- isdat2(i) = 0
-31 continue
- nsdat = 0
-c
-c Initialize flag for figures in any other voice than 1
-c
- ivxfig2 = 0
-c
-c Initialize for loop over gulps
-c
- firstgulp = .true.
-c
-c Start a gulp
-c
-30 loop = .true.
- notcrd = .true.
- isbjmp = .false.
- isbj2 = .false.
- autofbon = .false.
- tautofb = 0.
- nbars = 0
- nfigs(1) = 0
- nfigs(2) = 0
- ngrace = 0
- ntrill = 0
- ncrd = 0
- nudorn = 0
- nlit = 0
- nvolt = 0
- ibarmbr = 0
- nudsp = 0
-c ndyn = 0 ! 111109
- ntxtdyn = 0
- nbc = 0
- NumArpShift = 0
- do 3 i = 1 , 37
- graspace(i) = 0.
-3 continue
-c
-c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst.
-c and also if nv increases in an 'M' directive.
-c
- do 4 iv = 1 , nv
- call newvoice(iv,clefq(iv),.false.)
-4 continue
-c
-c Check if endsymbol was set earlier
-c
- if (rptnd1) then
- rptnd1 = .false.
- rptfq2 = rptfq1
- else
-c
-c Only use if movbrk>0, to signal default ('RD')
-c
- rptfq2 = 'E'
- end if
- iv = 1
- ivx = 1
-2 if (loop) then
-c
-c Within this loop, nv voices are filled up for the duration of the block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..).
-c nbars is for this input block.
-c Only at the beginning of an input block will there be a possible mtr change,
-c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change)
-c
- call getnote(loop)
- if (lastchar) go to 40
- go to 2
- end if
-c
-c Finished an input block (gulp).
-c
- if (ismidi) then
-c
-c Put rests into midi array for 2nd lines that were not used in this gulp.
-c
- do 60 iv = 1 , nv
- if (twoline(iv) .and. nvmx(iv).eq.1) then
- if (firstgulp .and. lenb0.ne.0) then
- call addmidi(midchan(iv,2),0,0,0,
- * (nbars-1.)*lenbar+lenb0,.true.,.false.)
- else
- call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true.,
- * .false.)
- end if
- end if
-60 continue
- end if
- nvolt = 0
- do 28 iv = 1 , nm
- nudoff(iv) = 0
- ndotmv(iv) = 0
-28 continue
-c
-c Put stuff at top of p.1. Must wait until now to have read title info.
-c
- if (ibarcnt .eq. 0) then
- call puttitle(inhnoh,xnsttop(ipage),
- * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
- bar1syst = ibarcnt .eq. iauto
- ndig = max(0,int(log10(.001+ibarcnt+ibcoff)))
- if (islast)
- * write(11,'(a11,i'//chax(50+ndig)//')')
- * '% Bar count',ibarcnt+ibcoff
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb)
- else
- if (.not.optimize) then
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- jprntb = 0
- end if
- ibcoff = ibcoff+mbrest-1
- if (ibar.eq.1 .and. firstgulp .and.
- * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize
-c
-c The above may be he only case where the space-before option is used in \mbrest
-c
- end if
-c
-c Move the read to after end-of-bar hardspace checks, so we get right poenom
-c at end of a line.
-c if (bar1syst) read(12,*) poenom
-c
-c Check for clef at start of bar. No slide yet. Also flags at end of prev.
-c bar. This block is run at the start of every bar. May fail for flag at
-c end of last bar. To account for necc. hardspaces, compute and store
-c nhssys = # of hard spaces for this system
-c hesk(nhssys) = elemskips avialable
-c hpts(nhssys) = hard points needed, including notehead
-c Here, merely insert placeholder into output. Later, when poe is computed,
-c compute additional pts and store them in hpttot(1...nhstot). Finally in
-c subroutine askfig, write true pts where placeholders are.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(1,ibar-1)
- clchb = btest(islur(1,ioff+1),15)
- putmbr = .false.
- if (ismbr) then
- if (clchb) then
-c
-c Clef change and multi-bar rest coming up. Kluge to get space at end of rest.
-c
- write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest'
- * //sq//'def'//sq//'mbrest#1#2#3{%'
- write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55,
- * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%'
- end if
- ismbr = .false.
- putmbr = .true.
- end if
- if (ibar .eq. ibarmbr) ismbr = .true.
-c
-c Set flag here so at start of next bar, if there's a clef change, can add space
-c after the mbr with the above kluge
-c
- if (.not.(clchb .or. flgndb)) go to 23
-c
-c Must check available space
-c
- ptsndb = 0.
-c
-c Zero out block signal
-c
- if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15)
-c
-c In this loop, we determine how much hardspace is needed (if any)
-c 9/7/97 Note that for last bar in input block, if number of lines of
-c music decreases in new block, highest numbered ones won't be checked
-c since the loop below covers the new nvmx(iv), not necessarily the old
-c one.
-c 4/18/98 Apparently nmxsav was a solution to the above problem
-c
- do 16 iv = 1 , nv
- do 16 kv = 1 , nvmxsav(iv)
- ivx = ivmxsav(iv,kv)
- ptsndv = flgndv(ivx)*wheadpt
- ioff = 0
- if (ibar .gt. 1) then
- ioff = nib(ivx,ibar-1)
- ip = ioff
- if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2)
-c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255))
- prevtn(ivx) = tnote(ipl2(ivx,ip))
-c
-c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar.
-c
- end if
-c
-c Only allow clef changes when ivx <= nv
-c
- if (ivx .le. nv) then
- clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11)
- if (clchv(iv)) then
-c
-c Clef change in this voice. Turn off signal. Get space avail.
-c
- islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11)
- if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv =
- * ptsndv+clefend*wheadpt
- end if
- end if
- ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac)
-16 continue
-c
-c ???? where is nb set??? nb probably in left over from makeabar
-c
- esk = feon(space(nb)*squez(nb))
- ptsdflt = esk*poenom-wheadpt
-c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then
- if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0
- * .and. .not.putmbr) then
-c
-c Must ADD hardspace! So put in a placeholder, and store params for later.
-c
- if (islast) write(11,'(a)')sq//'xardspace{ pt}%'
- nhssys = nhssys+1
- if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then
- hesk(nhssys) = esk
- hpts(nhssys) = ptsndb+wheadpt
- else
- hesk(nhssys) = eskgnd
- hpts(nhssys) = ptsgnd+wheadpt
- end if
- fixednew = fixednew+hpts(nhssys)
- scaldold = scaldold+hesk(nhssys)
- end if
- if (clchb) then
- do 17 iv = 1 , nv
- if (clchv(iv)) then
- notexq = sq//'znotes'
- lnote = 7
- do 24 iiv = 2 , iv
- notexq = notexq(1:lnote)//sepsymq(iiv-1)
- lnote = lnote+1
-24 continue
-c
-c Recompute ioff since it will vary from voice to voice
-c
- if (ibar .eq. 1) then
- ioff = 0
- else
- ioff = nib(iv,ibar-1)
- end if
-c
-c Must call clefsym to get nclef, even if there is a movement break
-c
- call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
- if (movbrk.eq.0 .and.
- * islast)
- * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%'
- call wsclef(iv,ninow,clefq,nclef)
- end if
-17 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- end if
-23 continue
-c
-c End of loop for end-of-bar hardspaces and non-movbrk clef symbol.
-c
- if (bar1syst) then
- read(12,*) poenom
- end if
-c
-c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1)
-c
- if (ibar .eq. 1) then
- islnow = islur(1,1)
- iornqnow = iornq(1,1)
- else
- islnow = islur(1,nib(1,ibar-1)+1)
- iornqnow = iornq(1,nib(1,ibar-1)+1)
- end if
-c
-c Check for R-symbols set at end of prior input block
-c
- if (movbrk.eq.0 .and. rptfq2.ne.'E') then
- if (rptfq2 .eq. 'D') then
- islnow = ibset(islnow,26)
- else if (rptfq2 .eq. 'r') then
- islnow = ibset(islnow,6)
- else if (rptfq2 .eq. 'd') then
- islnow = ibset(islnow,8)
- else if (rptfq2 .eq. 'b') then
- islnow = ibset(islnow,25)
- else
- print*
- print*,'Illegal symbol with "R" at end of input block:',
- * rptfq2
- call stop1()
- end if
- rptfq2 = 'E'
- end if
- if (iand(islnow,352) .ne. 0) then
-c
-c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set
-c
- lrpt = btest(islnow,5)
- rrpt = btest(islnow,6)
- lrptpend = lrpt.and.bar1syst
- if (lrpt .and. .not.lrptpend) then
- if (rrpt) then
- if (islast) write(11,'(a)')sq//'setleftrightrepeat'
- fixednew = fixednew+wheadpt*lrrptfac-0.4
- else
- if (islast) write(11,'(a)')sq//'setleftrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- end if
- else if (rrpt) then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- else if (btest(islnow,8)) then
- if (islast) write(11,'(a)')sq//'setdoublebar'
- fixednew = fixednew+wheadpt*dbarfac-0.4
- end if
- else if (btest(islnow,26)) then
-c
-c doubleBAR
-c
- if (islast) write(11,'(a)')sq//'setdoubleBAR'
- fixednew = fixednew+wheadpt*ddbarfac-0.4
- else if (btest(iornqnow,29)) then
-c
-c no bar line
-c
-c-- if (islast) write(11,'(a)')sq//'setzalaligne'
-c++
- if (islast) then
- if (movbrk .eq. 0) then
- write(11,'(a)')sq//'setzalaligne'
- else
-c
-c Encountered "Rz" at start of input block at start of new movement, Must
-c use newmovement macro with arg 4 rather than setzalaligne, since former
-c already redefines stoppiece.
-c
- rptfq2 = 'z'
- end if
- end if
-c++
- fixednew = fixednew-0.4
- end if
-c
-c 1st and 2nd endings
-c
- svolta = btest(islnow,7)
- evolta = btest(islnow,9)
- if (evolta) then
- if (btest(islnow,10)) then
- if (islast) write(11,'(a)')sq//'endvoltabox'
- else
- if (islast) write(11,'(a)')sq//'endvolta'
- end if
- onvolt = .false.
- end if
- if (svolta) then
- nvolt = nvolt+1
- lvoltxt = index(voltxtq(nvolt),' ')-1
- if (lvoltxt .eq. 1) then
- if (islast) write(11,'(a)')sq//'Setvolta'
- * //voltxtq(nvolt)(1:1)//'%'
- else
- if (islast) write(11,'(a)')sq//'Setvolta'//'{'//
- * voltxtq(nvolt)(1:lvoltxt)//'}%'
- end if
- onvolt = .true.
- end if
- if (ibar .gt. 1) then
- ipnow = nib(1,ibar-1)+1
- else
- ipnow = 1
- end if
- iplnow = ipl(1,ipnow)
- if (bar1syst) then
-c
-c If listslur>0, then there is at least one slur or tie carried over the break
-c
- ispstie = .false.
- if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0
- * .and. islast)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat,
- * ispstie,sepsymq)
- iline = iline+1
-c
-c End an old system, Start a new system
-c
- if (iline .ne. 1) then
-c
-c Not first line.
-c Get corrected poe = points/elemskip for *previous* system
-c
- wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- isyscnt = isyscnt+1
- poevec(isyscnt) = poe
-c
-c Transfer data for system into global arrays to hold until very end
-c
- do 9 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
-c
-c Only admit negative ask if it was user-defined space, signalled by elask<=0.
-c
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-9 continue
- do 25 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-25 continue
-c
-c Reset counters for new system
-c
- scaldold = 0.
- fixednew = 0.
- nasksys = 0
- nhssys = 0
- end if
-c
-c End of if block for first bar of non-first system. Still 1st bar, any system
-c
- if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%'
- isystpg = isystpg+1
-c
-c Try moving the next stmt way down, to fix a bug and get \eject printed at
-c end of single-system page.
-c if (isystpg .eq. nsystp(ipage)) isystpg = 0
- read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk
- if (iline .gt. 1) fracindent=frac
- if (figbass) then
- ifigdr(1,iline) = 4
- ifigdr(2,iline) = 4
- end if
- slfac = slfac1*musicsize*elsktot
- if (iline .ne. 1) then
-c
-c For the line just _finished_, put figdrop in separate file.
-c
- if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)')
- * sq//'figdrop=',ifigdr(1,iline-1),
- * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%'
-c
-c Check slurs in top staff for interference w/ barno. Only check when
-c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS
-c keep track of ons and offs when |isig|<=3.
-c
- ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1
- isnx = 0
- if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then
-c
-c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1
-c Look for termination in remainder of this input block. If not found,
-c just use is1n1. Remember, haven't slid down yet.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1)
- do 50 isdat = 1 , nsdat
- if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv))
- * .and. .not.btest(isdat1(isdat),11)
- * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then
-c
-c Found slur ending. Just check note height, can't do fine adjustments.
-c
-c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19))
- is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19))
- go to 51
- end if
-50 continue
-c
-c If exiting loop normally, did not find end of slur. c'est la vie.
-c
-51 continue
- isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd)
- if (isnx .gt. 0) then
-c
-c AHA! Slur likely to interfere with barno.
-c
-c Modified 090525 to use \bnrs
-c
- slint = .true.
- fmtq = '(a16,i1,a14)'
- if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)'
- if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{',
- * irzbnd+isnx,'.5'//sq//'internote}%'
-c if (islast) then
-c if (isnx .le. 9) then
-c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%'
-c else
-c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%'
-c end if
-c end if
-c
- end if
- end if
- if (movbrk .gt. 0) then
-c
-c movbrk = 0
-c Move the reset down, so can use movbrk>0 to stop extra meter prints.
-c
-c New movement. Redefine stoppiece, contpiece. These will be called either
-c explicitly or as part of alaligne.
-c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat.
-c This is passed to \newmovement.
-c
- if (rptfq2 .eq. 'E') rptfq2 = 'D'
- indsym = index('Ddrbz',rptfq2)-1
- rptfq2 = 'E'
-c
-c Also check for Rd or Rr set the normal way
-c
- if (btest(islnow,8)) then
- indsym = 1
- else if (btest(islnow,6)) then
- indsym = 2
- end if
- if (indsym .lt. 0) then
- print*
- print*,'Illegal end symbol before "/"'
- call stop1()
- end if
-c
-c Check for continuation (no bar number reset)
-c
- if (islast.and.
- * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1'
- * //sq//'startbarno'//sq//'barno%'
- if (movgap .lt. 10) then
- if (islast) write(11,'(a12,2i1,a1)')
- * sq//'newmovement',movgap,indsym,'%'
- else
- if (islast) write(11,'(a13,i2,a1,i1,a1)')
- * sq//'newmovement{',movgap,'}',indsym,'%'
- end if
-c
-c Change generalmeter if necessary
-c
- if (islast) call wgmeter(mtrnmp,mtrdnp)
-c
-c (Moved all name-writing to getnote, right when 'M' is detected)
-c
- if (btest(iplnow,28)) then
-c
-c Key signature at movement break
-c
- iplnow = ibclr(iplnow,28)
- if (isig .gt. 0) then
- if (islast) write(11,'(a18,i1,a2)')
- * sq//'generalsignature{',isig,'}%'
- else
- if (islast) write(11,'(a18,i2,a2)')
- * sq//'generalsignature{',isig,'}%'
- end if
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- end if
- if (parmov .ge. -.1) then
-c
-c Resent paragraph indentation
-c
- ipi = parmov*widthpt+.1
- if (ipi .lt. 10) then
- if (islast) write(11,'(a11,i1,a2)')
- * sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- if (islast)
- * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- if (islast)
- * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- end if
- end if
- if (isystpg .eq. 1) then
-c
-c First line on a page (not 1st page, still first bar). Tidy up old page
-c then eject.
-c
-c Removed this 5/13/01 as it was causing double endvoltas. This probably
-c is only needed at the end in case there is no endvolta specified.
-c if (onvolt) then
-cc if (islast) write(11,'(a)')sq//'endvoltabox%'
-cc onvolt = .false.
-c end if
-c
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page. Ugly repeated coding here.
-c
- mtrnms = mtrnuml
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- mtrnuml = mtrnms
- if (movbrk .eq. 0 .and. islast)
- * call wgmeter(mtrnmp,mtrdnp)
- end if
-c
-c Key signature change?
-c
- if (btest(iplnow,28) .and. movbrk.eq.0) then
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')
- * notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-'//sq//'afterruleskip}'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue%'
- else if (mtrnuml.gt.0 .and. movbrk.eq.0) then
-c
-c Meter change but no signature change
-c
- if (islast)
- * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'//
- * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq//
- * 'barnoadd%'
- if (islast)
- * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'//
- * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%'
- else
- if (islast) write(11,'(a)')sq//'stoppiece%'
- end if
-c
-c This is the key spot when vshrink is used. Value of vshrink here comes from
-c just after the prior pagebreak, i.e., it is not affected by "Av"
-c that may have been entered at this pagebreak, since that only affects usevshrink.
-c So choose page *ending* (with or without \vfill) depending on old vshrink. Then
-c check value of usevshrink to reset vshrink if necessary for the new page, where
-c we have to set \interstaff and later call puttitle.
-c Top of first page needs special treatment. For this we use
-c novshrinktop, which was set in g1etnote on the first pass, since on
-c second pass, vshrink at top of page one is dealt with in topfile, which is called
-c *before* any reading in any "Av" at the top of the first input block.
-c
- if (.not.vshrink) then
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject%'
- else
- if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%'
- end if
- ipage = ipage+1
-c
-c Now that page is ejected, compute new vshrink
-c
- vshrink = xintstaff(ipage).gt.20 .and. usevshrink
- if (vshrink) then
- xinsnow = 10
- else
- xinsnow = xintstaff(ipage)
- end if
- if (fintstf.gt.0 .and. ipage.gt.1) then
- xinsnow = xinsnow*fintstf/gintstf
- fintstf = -1.
- end if
- if (xinsnow .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else if (xinsnow .lt. 99.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
-c
-c Vertical spacing parameters, then restart
-c
- if (islast) write(11,fmtq)sq//'interstaff{',xinsnow,
- * '}'//sq//'contpiece'
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) write(11,'(a)')sq//'newtimes2%'
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- end if
- end if
- end if
-c
-c If no real titles here, which there probably will never be, make vertical
-c space at page top with \titles{...}. headlog=.false.<=>no real titles
-c
- call puttitle(inhnoh,xnsttop(ipage),etatop,
- * sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- else
-c
-c First bar of system, not a new page, force line break
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (mtrnuml .ne. 0) then
-c
-c Meter+sig change, new line, may need mods if movement break here.
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'xchangecontext'//sq//
-c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'
- * 'addspace{-'//sq//'afterruleskip}'
-c * //sq//'writezbarno{}'//sq//'zalaligne%'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- write(11,'(a)')sq//'addspace{-'//sq
- * //'afterruleskip}%'
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'zchangecontext'
- end if
- else
- if (islast) write(11,'(a)')sq//'xchangecontext'//sq//
-c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'//
- * 'addspace{-'//sq//'afterruleskip}'
-c * sq//'writezbarno{}'//sq//'zalaligne%'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- end if
- else if (mtrnuml .eq. 0) then
-c
-c No meter change
-c
- if (islast) write(11,'(a)')sq//'alaligne'
- else
-c
-c New meter, no new sig, end of line, not new page.
-c
-c \generalmeter{\meterfrac{3}{4}}%
-c \xchangecontext\addspace{-\afterruleskip}%
-c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}%
-c \zchangecontext
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) then
- write(11,'(a)')
- * sq//'let'//sq//'bnat'//sq//'barnoadd'
- * //sq//'def'//sq//'barnoadd{'//sq//'empty}%'
- write(11,'(a)')sq//'xchangecontext'//sq//
- * 'addspace{-'//sq//'afterruleskip}'//sq//
- * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat'
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'zchangecontext'
- end if
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- end if
- end if
-c
-c Modified 090525 to use \bnrs
-c
- if (slint) then
- slint = .false.
- if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq//
- * 'raisebarno{',irzbnd,'.5'//sq//'internote}%'
- end if
- movbrk = 0
- end if
-c
-c Clean up if we squelched bar number reset at movement break
-c
- if (nobar1) then
- if (islast) write(11,'(a)')sq//'startbarno1'
- nobar1 = .false.
- end if
- read(12,*,end=14)iauto
-14 continue
-c
-c We come thru here for the 1st bar of every system, so initialize is1n1
-c
- is1n1 = 0
-c
-c Brought down from above
-c
- if (isystpg .eq. nsystp(ipage)) isystpg = 0
-c
-c Check for linebreak ties
-c
- if (ispstie)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- else
-c
-c Not first bar of system
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- if (mtrnuml .ne. 0) then
-c
-c Meter+signature change mid line, assume no movement break
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:18)//'-'
- lnote = 19
- end if
- if (islast) then
- iptemp = 48+abs(isig)
- charq = chax(iptemp)
- notexq = notexq(1:lnote)//charq//'}%'
- lnote = lnote+3
- write(11,'(a)')notexq(1:lnote)
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- write(11,'(a)')sq//'xchangecontext%'
- end if
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
- xb4mbr = (facmtr+naccs*.24)*musicsize
- end if
- else
-c
-c Signature change only
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast)
- * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'// sq//'afterruleskip}%'
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
- xb4mbr = naccs*.24*musicsize
- end if
- end if
- else if (mtrnuml .eq. 0) then
-c
-c No meter change
-c
- if (islast) write(11,'(a)')sq//'xbar'
- else
-c
-c Change meter midline
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%'
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- else
- if (islast) write(11,'(a)')sq//'xbar'
- end if
- end if
- end if
- end if
-c
-c Now that xbar's are written, can put in left-repeats at line beginnings
-c
- if (lrptpend) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1'
- * //sq//'leftrepeat'
- lrptpend = .false.
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nolev(ivx,ip) = nolev(ivx,ip+ioff)
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
- irest(ivx,ip) = irest(ivx,ip+ioff)
- islur(ivx,ip) = islur(ivx,ip+ioff)
- ipl(ivx,ip) = ipl(ivx,ip+ioff)
- iornq(ivx,ip) = iornq(ivx,ip+ioff)
- mult(ivx,ip) = mult(ivx,ip+ioff)
-c if (ivx.le.2 .and. figbass)
-c * isfig(ivx,ip) = isfig(ivx,ip+ioff)
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- if (ivx.eq.1) then
- isfig(1,ip) = isfig(1,ip+ioff)
- else
- isfig(2,ip) = isfig(2,ip+ioff)
- end if
- end if
-12 continue
- if (ivx.le.nv .and. ncc(iv).gt.1) then
- islide = 0
- do 13 icc = 1 , ncc(iv)
- if (tcc(iv,icc) .le. lenbar) then
-c
-c This time will drop <=0 when slid.
-c
- islide = icc-1
- ncmidcc(iv,1) = ncmidcc(iv,icc)
- else
- tcc(iv,icc-islide) = tcc(iv,icc)-lenbar
- ncmidcc(iv,icc-islide) = ncmidcc(iv,icc)
- end if
-13 continue
- ncc(iv) = ncc(iv)-islide
- tcc(iv,1) = 0.
- end if
-11 continue
- do 15 ig = 1 , ngrace
- ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1)
- if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2)
-15 continue
- do 21 il = 1 , nlit
- iplit(il) = iplit(il)-nib(ivlit(il),ibar-1)
- if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2)
-21 continue
- do 22 it = 1 , ntrill
- iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1)
- if (ibar .gt. 2) iptrill(it) =
- * iptrill(it)+nib(ivtrill(it),ibar-2)
-22 continue
- do 27 icrd = 1 , ncrd
-c ivx = iand(15,ishft(icrdat(icrd),-8))
- ivx = iand(15,ishft(icrdat(icrd),-8))
- * +16*igetbits(icrdat(icrd),1,28)
- ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- icrdat(icrd) = iand(not(255),icrdat(icrd))
- icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd))
-27 continue
- do 29 iudorn = 1 , nudorn
-c ivx = iand(15,ishft(kudorn(iudorn),-8))
- ivx = ivxudorn(iudorn)
- ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- kudorn(iudorn) = iand(not(255),kudorn(iudorn))
- kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn))
-29 continue
- do 42 idyn = 1 , ndyn
- idynd = idyndat(idyn)
-c ivx = iand(15,idynd)
- ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10)
- ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
-c
-c The following construction avoids array bound errors in some compilers
-c
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(idynd,8,4,ipnew)
- idyndat(idyn) = idynd
-42 continue
- do 43 itxtdyn = 1 , ntxtdyn
- idynd = ivxiptxt(itxtdyn)
-c ivx = iand(15,idynd)
- ivx = iand(31,idynd)
-c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
- ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
-c call setbits(idynd,8,4,ipnew)
- call setbits(idynd,8,5,ipnew)
- ivxiptxt(itxtdyn) = idynd
-43 continue
- do 41 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1)
- ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(isdata,8,3,ipnew)
- isdat1(isdat) = isdata
-41 continue
- do 44 ibc = 1 , nbc
-c ivx = iand(15,ibcdata(ibc))
- ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(ibcdata(ibc),8,4,ipnew)
-44 continue
- do 45 iarps = 1 , NumArpShift
- IpArpShift(iarps) =
- * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1)
- if (ibar .gt. 2) then
- IpArpShift(iarps) =
- * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2)
- end if
-45 continue
-c
-c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left.
-c If there are figs left, it will reset all times relative to start of
-c current bar.
-c
- do 46 ivx = 1 , 2
- if (figbass) then
- islide = 0
- do 20 jfig = 1 , nfigs(ivx)
- if (itfig(ivx,jfig) .lt. lenbar) then
-c
-c This figure was already used
-c
- islide = jfig
- else
- itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar
- figq(ivx,jfig-islide) = figq(ivx,jfig)
- itoff(ivx,jfig-islide) = itoff(ivx,jfig)
- ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig)
- end if
-20 continue
- nfigs(ivx) = nfigs(ivx)-islide
- end if
- if (nfigs(2) .eq. 0) go to 47
-46 continue
-47 continue
- end if
-c
-c End of sliding down for bars after first in gulp.
-c
-c The following may not be needed by makeabar, but just in case...
-c
- if (firstgulp .and. lenb0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
- end if
-c
-c Equal line spacing stuff
-c
- if (equalize .and. bar1syst) then
- if (isystpg .eq. 1) then
- write(11,'(a)')sq//'starteq%'
- else if (isystpg .eq. nsystp(ipage)-1) then
- write(11,'(a)')sq//'endeq%'
- end if
- end if
- call make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- call make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
-c
-c Hardspace before barline?
-c
- hardb4 = 0.
- do 35 iv = 1 , nv
- do 35 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (btest(irest(ivx,nn(ivx)),18)) then
- nudoff(ivx) = nudoff(ivx)+1
- hardb4 = max(hardb4,udoff(ivx,nudoff(ivx)))
- end if
-35 continue
- if (hardb4 .gt. 0.) then
- if (islast) write(11,'(a11,f5.1,a4)')sq
- * //'hardspace{',hardb4,'pt}%'
- fixednew = fixednew-hardb4
- end if
-10 continue
- firstgulp = .false.
- lenb0 = 0
- go to 30
-40 close(12)
- close(13)
- ilbuf = 1
- ipbuf = 0
- wdpt = widthpt
- if (iline .eq. 1) wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- poevec(nsyst) = poe
- if (.not.islast) then
- close(11)
- close(16)
- if (figbass) close(14)
- return
- end if
- do 19 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-19 continue
- do 26 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-26 continue
- if (islast .and.
- * onvolt) write(11,'(a)')sq//'endvoltabox'
- if (rptfq2 .ne. 'E') then
-c
-c Terminal repeat. Right or double?
-c
- if (rptfq2 .eq. 'r') then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- * //sq//'endpiece'
- else if (rptfq2 .eq. 'd') then
- if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece'
- else if (rptfq2 .eq. 'b') then
- if (islast) write(11,'(a)')sq//'endpiece'
- else if (rptfq2 .eq. 'z') then
- if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece'
- else
-c else if (rptfq2 .ne. 'D') then
- print*
- print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- if (islast) write(11,'(a)')sq//'Endpiece'
- end if
- else
- if (islast) write(11,'(a)')sq//'Endpiece'
- end if
- if (.not.vshrink) then
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- else
- if (islast) write(11,'(a)')
- * sq//'vfill'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- end if
- rewind(11)
- if (figbass) then
- write(14,'(a9,i2,a10,i2,1x,a5)')
- * sq//'figdrop=',ifigdr(1,iline),
- * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%'
- rewind(14)
- end if
- call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- if (.not.optimize) then
- print*
- print*,'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- print*,'Done with second PMX pass.'
- write(15,'(/,a)')'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- write(15,'(a)')' Done with second PMX pass. Now run TeX'
- end if
- return
- end
- subroutine poestats(nsyst,poe,poebar,devnorm)
- parameter (nks=125)
-c
-c Compute avg. & norm. std. dev. of poe.
-c
- real*4 poe(nks)
- sumx = 0.
- sumxx = 0.
- do 1 isyst = 1 , nsyst
- sumx = sumx+poe(isyst)
- sumxx = sumxx+poe(isyst)**2
-1 continue
-2 continue
- devnorm = sqrt(nsyst*sumxx/sumx**2-1)
- poebar = sumx/nsyst
- return
- end
- subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq,
- * twooftwo,icashft)
-c
-c Analyzes chords, data to be used with slurs on chords and plain chords.
-c Check for 2nds, shift notes if neccesary.
-c ipl(10) chord present
-c irest(20) set if any note is right shifted
-c irest(27) set if any note is left shifted
-c ipl(8|9) left|right shift main note
-c icrdat(23|24) ditto chord note
-c udq is updown-ness, needed to analyze 2nds.
-c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note.
-c icrdot(icrd)(27-29) sequence order of chord note if accid, top down
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,is2nd,twooftwo
- integer*4 kicrd(10),levtabl(88)
- character*1 udq
- do 11 i = 1 , 88
- levtabl(i) = 0
-11 continue
- do 1 icrd1 = 1 , ncrd
- ivx1 = iand(15,ishft(icrdat(icrd1),-8))
- * +16*igetbits(icrdat(icrd1),1,28)
- ip1 = iand(255,icrdat(icrd1))
- if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2
-1 continue
- print*
- print*,
- * 'Cannot find first chord note in precrd. Send source to Dr. Don!'
- call stop1()
-2 continue
- maxlev = nolevm
- minlev = nolevm
- levtabl(nolevm) = -1
- is2nd = .false.
- naccid = 0
- levmaxacc = -100
- levminacc = 1000
-c
-c Check 1st 3 bits of nacc for accid on main note of chord.
-c
- if (iand(7,nacc) .gt. 0) then
- naccid = 1
-c
-c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main,
-c otherwise icrd value for note with accidental.
-c
- kicrd(1) = 0
- levmaxacc = nolevm
- levminacc = nolevm
-c
-c Start the level-ranking
-c
- icrdot0 = 1
- end if
- do 3 icrd2 = icrd1 , ncrd
- nolev = igetbits(icrdat(icrd2),7,12)
- levtabl(nolev) = icrd2
- maxlev = max(maxlev,nolev)
- minlev = min(minlev,nolev)
-c
-c Check for accidental
-c
- if (btest(icrdat(icrd2),19)) then
- naccid = naccid+1
- levmaxacc = max(levmaxacc,nolev)
- levminacc = min(levminacc,nolev)
-c
-c Add this icrd to list of values for notes with accid's.
-c
- kicrd(naccid) = icrd2
- if (.not.btest(nacc,28)) then
-c
-c Order not forced, so get the level-ranking, top down
-c
- iorder = 1
- do 12 iaccid = 1 , naccid-1
- if (kicrd(iaccid) .eq. 0) then
- if (nolevm .gt. nolev) then
- iorder = iorder+1
- else
- icrdot0 = icrdot0+1
- end if
- else
- if (igetbits(icrdat(kicrd(iaccid)),7,12)
- * .gt. nolev) then
- iorder = iorder+1
- else
- iold = igetbits(icrdot(kicrd(iaccid)),3,27)
- call setbits(icrdot(kicrd(iaccid)),3,27,iold+1)
- end if
- end if
-12 continue
- call setbits(icrdot(icrd2),3,27,iorder)
- end if
- end if
-c
-c Exit loop if last note in this chord
-c
- if (icrd2 .eq. ncrd) go to 4
- if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or.
-c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4
- * igetbits(icrdat(icrd2+1),4,8)
- * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4
-3 continue
- print*
- print*,'Failed to find last chord note. Send source to Dr. Don!'
- call stop1()
-4 continue
-c
-c Now icrd1, icrd2 define range of icrd for this chord.
-c
-c Bypass autos-shifting if any manual shifts are present
-c
- if (btest(irest,20) .or. btest(irest,27)) go to 10
-c
-c Check for 2nds
-c
- do 5 ilev = 1 , 87
- if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then
-c
-c There is at least one 2nd..
-c
- if (udq .eq. 'u') then
-c
-c Upstem. Start with 2nd just found and go up, rt-shifting upper
-c member of each pair
-c
- ile = ilev
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,20)
-7 continue
- if (levtabl(ile+1) .lt. 0) then
-c
-c Upstem, & upper member is main so must be rt-shifted. This would move
-c stem too, so we rt-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,30)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24)
- else
-c
-c Upper member is chord note, must be rt-shifted
-c
- icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24)
- end if
- ile = ile+1
-8 continue
- ile = ile+1
- if (ile .lt. 87) then
- if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then
- go to 7
- else
- go to 8
- end if
- end if
- go to 10
- else
-c
-c Downstem. Start at top and work down, left-shifting lower member of each pair.
-c We know that lowest pair is at (ilev,ilev+1).
-c
- ile = 88
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,27)
-9 continue
- if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then
- if (levtabl(ile-1) .lt. 0) then
-c ipl = ibset(ipl,8)
-c
-c Dnstem, & lower member is main so must be left-shifted. This would move
-c stem too, so we left-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,31)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23)
- else
-c
-c Lower member is chord note, must be shifted
-c
- icrdat(levtabl(ile-1)) =
- * ibset(icrdat(levtabl(ile-1)),23)
- end if
- ile = ile-1
- end if
- ile = ile-1
- if (ile .ge. ilev+1) go to 9
- go to 10
- end if
- end if
-5 continue
-10 continue
-c
-c Done with 2nds, now do accid's. Call even if just one, in case left shifts.
-c
-c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid,
- if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid,
- * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft)
- return
- end
- subroutine printl(string)
- character*(*) string
-c
-c Send string to console and to log file
-c
- print*,string
- write(15,'(a)')string
- return
- end
- subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- logical lowdot,IsArpShift
- character*80 soutq
- character*79 notexq
- character*8 symq(2)
- character*1 chax
- data symq /'raisearp','arpeggio'/
-
-c
-c Find which iarp, if any
-c
- do 1 iarp = 1 , narp
- if (abs(tnow-tar(iarp)).lt.tol) go to 2
-1 continue
-c
-c If here, this is the *first* call for this arp.
-c
- narp = narp+1
- tar(narp) = tnow+tol*.5
- ivar1(narp) = iv
- ipar1(narp) = ip
- levar1(narp) = nolev
- ncmar1(narp) = ncm
- return
-2 continue
-c
-c If here, this is *second* call at this time, iarp points to values from 1st.
-c
-c Check for shift. Set IsArpShift and iarps
-c
- do 3 iarps = 1 , NumArpShift
- if (IvArpShift(iarps) .eq. ivar1(iarp) .and.
- * IpArpShift(iarps) .eq. ipar1(iarp)) then
- IsArpShift = .true.
- notexq = chax(92)//'loffset{'
- write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{'
- lnote = 14
- go to 4
- end if
-3 continue
- IsArpShift = .false.
- lnote = 0
-4 continue
- if (iv .eq. ivar1(iarp)) then
-c
-c Arp is in a single staff.
-c
- levbot = min(levar1(iarp),nolev)-ncm+3
- invert = abs(levar1(iarp)-nolev)+1
- else
-c
-c Arp covers >1 staff. Lower staff has to be the first, upper is current and
-c is where the symbol will be written.
-c
- levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
- invert = -levbot+4+nolev-ncm
-c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:'
-c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp),
-c *levbot,nolev,ncm
- end if
-c
-c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote
-c
- isym = mod(invert,2)+1
- ilvert = (invert+1)/2
- if (levbot .ge. 0 .and. levbot .le. 9) then
-c
-c Single digit
-c
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//chax(48+levbot)
- else
- notexq = notexq(1:lnote)//
- * chax(92)//symq(isym)//chax(48+levbot)
- end if
- lnote = lnote+10
- else
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//'{'
- else
- notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{'
- end if
- lnote = lnote+10
- if (levbot .ge. -9) then
-c
-c Need two spaces for number
-c
- write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}'
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}'
- lnote = lnote+4
- end if
- end if
-c if (ilvert .le. 9) then
-c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1,
-c * soutq,lsout)
-c else
-c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
-c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout)
-c end if
-
- if (ilvert .gt. 9) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+ilvert)
- lnote = lnote+1
- end if
- if (IsArpShift) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
-c
-c cancel out the stored time, to permit two arps at same time!
-c
- tar(iarp) = -1.
- return
- end
- subroutine putast(elask,indxask,outq)
- character*129 outq,tag
- character*9 fmtq
- if (elask .ge. 0.) then
- if (elask.lt.0.995) then
- lp = 3
- else if (elask .lt. 9.995) then
- lp = 4
- else
- lp = 5
- end if
- write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)'
- else
- lp = 5
- fmtq = '(a2,f5.1)'
- end if
-c
-c Overwrite as follows: ...xyz*ask *lmnop... ->
-c ...xyz*ast{.nn}*lmnop...
-c ...xyz*ast{n.nn}*lmnop...
-c ...xyz*ast{nn.nn}*lmnop...
-c or for negative, ...xyz*ast{-nn.n}*lmnop...
- tag = outq(indxask+9:)
- write(outq(indxask+3:),fmtq)'t{',elask
- outq = outq(1:indxask+4+lp)//'}'//tag
- return
- end
- subroutine putcb(ivx,ip,notexq,lnote)
- common /comcb/ nbc,ibcdata(36)
- character*79 notexq
- logical btest
-c ivxip = ivx+16*ip
- do 1 ibc = 1 , nbc
-c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2
-c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
-c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2
- ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipbc = igetbits(ibcdata(ibc),8,4)
- if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2
-1 continue
- call printl('Error in putbc, Call Dr. Don')
- stop
-2 continue
- if (btest(ibcdata(ibc),27)) then
- lnote = 8
- notexq = char(92)//'pbreath'
- else
- lnote = 9
- notexq = char(92)//'pcaesura'
- end if
- ivshft = igetbits(ibcdata(ibc),6,13)
-c?? ivshft = igetbits(ibcdata(ibc),6,13)-32
- if (ivshft .gt. 0) ivshft = ivshft-32
- if (ivshft.lt.0 .or. ivshft.gt.9) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (ivshft .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')ivshft
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')ivshft
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//char(48+ivshft)
- lnote = lnote+1
- end if
- ihshft = igetbits(ibcdata(ibc),8,19)
- if (ihshft .eq. 0) then
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
- hshft = .1*(ihshft-128)
-c
-c -12.8<hshft<12.8
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (hshft .lt. -9.95) then
- write(notexq(lnote+1:lnote+5),'(f5.1)')hshft
- lnote = lnote+5
- else if (hshft.lt.-0.05 .or. hshft.gt.9.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')hshft
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+3),'(f3.1)')hshft
- lnote = lnote+3
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine putfig(ivx,ifig,offnsk,figcheck,soutq,lsout)
- parameter (nm=24)
- common /comfig/ itfig(2,74),figqq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figqq,figq
- character*80 soutq,notexq
- character*1 ch1q,ch2q,sq,chax
- character*5 nofq,nofaq
- character*4 Figutq,Conttq
- logical figcheck
- if (ivx .eq. 1) then
- Figutq = 'Figu'
- Conttq = 'Cont'
- else
- Figutq = 'Figt'
- Conttq = 'Cott'
- end if
- sq = chax(92)
- if (abs(offnsk) .gt. .0001) then
-c
-c Write offset for floating figure, to two decimal places
-c
- notexq = sq//'off{'
- if (-offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')-offnsk
- lnote = 11
- else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')-offnsk
- lnote = 10
- else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')-offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')-offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- figq = figqq(ivx,ifig)
- ic = 1
-c nof = 0
-c nofa = -1
- nof = -ivupfig(ivx,ifig)
- nofa = -ivupfig(ivx,ifig)-1
-c
-c Beginning of manual loop
-c
-1 ch1q = figq(ic:ic)
-c
-c Exit when first blank is encountered
-c
- if (ch1q .eq. ' ') go to 2
-c
-c Starting a level. Set up vertical offset.
-c
-c lnof = 1
-c nofq = chax(nof+48)
-c if (nof .gt. 9) then
-c lnof = 2
-c nofq = '1'//chax(nof-10+48)
-c end if
-c if (nofa .eq.-1) then
-c lnofa = 2
-c nofaq = '-1'
-c else if (nofa .lt. 10) then
-c lnofa = 1
-c nofaq = chax(nofa+48)
-c else
-c lnofa = 2
-c nofaq = '1'//chax(nofa+38)
-c end if
- call istring(nof,nofq,lnof)
- call istring(nofa,nofaq,lnofa)
- if (ch1q .eq. '0') then
-c
-c Continuation figure. Next number is length (in noteskips). The number will
-c end at the first blank or char that is not digit or decimal point. If
-c colon, it is a separator and must be skipped
-c
- icnum = ic+1
-3 continue
- ic = ic+1
- if (index('0123456789.',figq(ic:ic)) .gt. 0) go to 3
- lnum = ic-icnum
- call addstr(sq//Conttq//nofq(1:lnof)//'{'
- * //figq(icnum:ic-1)//'}',7+ic-icnum+lnof,soutq,lsout)
- if (figq(ic:ic) .ne. ':') ic=ic-1
- else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then
- ic = ic+1
- ch2q = figq(ic:ic)
- if (ch2q .eq. ' ') then
-c
-c Figure is a stand-alone accidental, so must be centered
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'sharpfig}',16+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'flatfig}',15+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'natfig}',14+lnofa,soutq,lsout)
- end if
- go to 2
- else
-c
-c Figure is an accidental followed by a number
-c First put the accidental (offset to the left)
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmsh}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmfl}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmna}',
- * 13+lnofa,soutq,lsout)
- end if
-c
-c Now put the number
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch2q//'}',
- * 8+lnof,soutq,lsout)
- endif
- else if (ch1q .eq. '_') then
-c
-c Placeholder only (for lowering a figure). Don't do anything!
-c
- continue
- else
-c
-c Figure is a single number, maybe with s after
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{',
- * 6+lnof,soutq,lsout)
- ch2q = figq(ic+1:ic+1)
- if (ch2q .eq. 's') then
-c
-c Use a special character. Insert font call
-c
- ic = ic+1
- call addstr(sq//'ligfont',8,soutq,lsout)
- end if
- call addstr(ch1q//'}',2,soutq,lsout)
-c call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}',
-c * 8+lnof,soutq,lsout)
- end if
- if (ic .ge. 10) go to 2
- ic = ic+1
- nof = nof+4
- nofa = nofa+4
- go to 1
-2 continue
- if (abs(offnsk) .gt. .0001) then
- notexq = sq//'off{'
- if (offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')offnsk
- lnote = 11
- else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')offnsk
- lnote = 10
- else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- if (ifig .lt. nfigs(ivx)) then
- ifig = ifig+1
- else
- nfigs(ivx) = 0
- figcheck = .false.
- end if
- return
- end
- subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
- * ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt,
- * beamon,iscrd)
-c
-c All args are individual array element *values* except nornb,ihornb,ulq.
-c notcrd = .true. if ornament is on main note.
-c nolevm is level of main note (for chords)
-c
- parameter (nm=24)
- character*1 ulpzq,ulq(nm,9),udqq,sq,chax
- character*8 noteq
- character*79 notexq,outq
- integer*4 ihornb(nm,24),nornb(nm)
- logical btest,iscrd,usehornb,beamon
- 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
- sq = chax(92)
- lout = 0
- usehornb = .false.
- if (nodur .lt. 64) then
- stemlen = stemlin
- else
- stemlen = 0.
- end if
-c
-c Get up-downness. ulpzq is opposite from stem direction for both beams and
-c non beams. Can use in name of ornament [ . or _ ]
-c
- if (beamon) then
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- ulpzq = 'l'
- else
- ulpzq = 'u'
- end if
- else
- if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then
- ulpzq = 'u'
- else
- ulpzq = 'l'
- end if
- end if
-c
-c To enable >1 ornament on a note, next line is top of manual loop.
-c
-2 continue
-c
-c Bit # of last ornament (last of bits 0-21)
-cc Bit # of last ornament (last of bits 0-24)
- ibit = log2(iand(iornq,4194303))
-c ibit = log2(iand(iornq,33554431))
- iornt = 2**ibit
-c
-c Begin routine to set height. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c 19-20: >^, 21: ? (with or w/o 16-18)
-c
-c Do not use beam height for . or _
-c
- if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then
-c
-c Height is set by special beam stuff.
-c Do not leave ihorn set, do separately for every ornament
-c
- ihorn = ihornb(ivx,nornb(ivx))
- if (ulpzq .eq. 'u') ihorn = ihorn-2
-c
-c Following flag tells whether to increment nornb when exiting the subroutine.
-c
- usehornb = .true.
- else if (ibit .eq. 14) then
-c
-c Down fermata. Don't worry about upper chord notes.
-c
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev,ncm-3)
- else
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (btest(iornt,13) .or. btest(iornt,0)) then
-c
-c ( or )
-c
- ihorn = nolev
- else if (iand(iornt,6144) .gt. 0) then
-c
-cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info
-c NOTE: removed .&_ from special beam treatment.
-c Staccato . or tenuto _ Need up-down info
-c
- if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or.
- * (minlev.ne.nolev.and.ulpzq.eq.'u')) then
- ihorn = nolev
- else if (maxlev .eq. nolev) then
- ulpzq = 'u'
- ihorn = max(nolev+stemlen,ncm+3.)
- else
- ulpzq = 'l'
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (iscrd .and. nolev .eq. minlev) then
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev-3,ncm-6)
- else
- ihorn = min(nolev-nint(stemlen)-3,ncm-6)
- end if
- else if (ibit.eq.10 .and. nolev.gt.90) then
-c
-c Special treatment for fermata on a shifted rest
-c
- ihorn = ncm+5
- else if (ulpzq.eq.'l') then
-c
-c (iscrd and nolev=maxlev) or (.not.iscrd)
-c
- ihorn = max(nolev+stemlen+2,ncm+5.)
- else
- ihorn = max(nolev+2,ncm+5)
- end if
- ioff = 0
- iclracc = 0
-c
-c Begin routine to set name. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c
- if (btest(iornt,2)) then
- notexq = sq//'shake'
- lnote = 6
- else if (btest(iornt,3)) then
- notexq = sq//'mordent'
- lnote = 8
- else if (btest(iornt,1)) then
- notexq = sq//'mtr'
- lnote = 4
- else if (btest(iornt,5)) then
- notexq = sq//'xtr'
- lnote = 4
- else if (btest(iornt,6)) then
- notexq = sq//'ptr'
- lnote = 4
- else if (btest(iornt,13)) then
- notexq = sq//'rpn'
- lnote = 4
- else if (btest(iornt,0)) then
- notexq = sq//'lpn'
- lnote = 4
- else if (btest(iornt,12)) then
- notexq = sq//ulpzq//'st'
- lnote = 4
- else if (btest(iornt,11)) then
- notexq = sq//ulpzq//'pz'
- lnote = 4
- else if (btest(iornt,8)) then
- notexq = sq//'upz'
- lnote = 4
- ioff = -2
- else if (btest(iornt,9)) then
- notexq = sq//'uppz'
- lnote = 5
- ioff = -2
- else if (btest(iornt,10)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermataup'
- else
- notexq = sq//'Fermataup'
- end if
- lnote = 10
- ioff = -2
- else if (btest(iornt,14)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermatadown'
- else
- notexq = sq//'Fermatadown'
- end if
- lnote = 12
- else if (btest(iornt,21)) then
-c
-c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21
-c
- if (btest(iornq,16)) then
- notexq = sq//'qsharp'
- lnote = 7
- ioff = 2
- iornq = ibclr(iornq,16)
- iclracc = 16
- else if (btest(iornq,17)) then
- notexq = sq//'qflat'
- lnote = 6
- ioff = 1
- iornq = ibclr(iornq,17)
- iclracc = 17
- else if (btest(iornq,18)) then
- notexq = sq//'qnat'
- lnote = 5
- ioff = 2
- iornq = ibclr(iornq,18)
- iclracc = 18
- else
- notexq = sq//'qedit'
- lnote = 6
- ioff = 0
- end if
- else if (btest(iornt,16)) then
- notexq = sq//'esharp'
- lnote = 7
- ioff = 2
- else if (btest(iornt,17)) then
- notexq = sq//'eflat'
- lnote = 6
- ioff = 1
- else if (btest(iornt,18)) then
- notexq = sq//'enat'
- lnote = 5
- ioff = 2
- else if (btest(iornt,19)) then
- notexq = sq//'usf'
- lnote = 4
- ioff = -2
- else if (btest(iornt,20)) then
- notexq = sq//'usfz'
- lnote = 5
- ioff = -2
- end if
- iudorn = 0
-c
-c User-defined level shift of ornament from default?
-c
- if (btest(iornq,25)) then
-c
-c Find which (if any) element of kudorn has the shift.
-c
- do 3 iudorn = 1 , nudorn
- if (ibit .lt. 21) then
- ibitt = ibit
-c
-c Could have oes, but not oe? or oes?
-c
- else if (iclracc .gt. 0) then
-c
-c Earlier cleared edit. accid, meaning it was oes?
-c
- ibitt = iclracc+6
- else
- ibitt = 21
- end if
- ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19)
-c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4
- if (ibitt .eq. iand(33554431,kudorn(iudorn))
- * .and. ivx.eq.ivxudorn(iudorn)) go to 4
-3 continue
-c
-c Nothing shifted on this note; exit this if block
-c
- iudorn = 0
- go to 5
-4 continue
- ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32
- if (ibit.eq.19 .and. ioffinc .lt. -7) then
-c
-c Convert usf to lsf. The reason has to do with positioning being impossile
-c for some mysterious reason when you drop \usf below the staff
-c
- notexq = sq//'lsf'
- ioffinc = ioffinc+6
- end if
- ioff = ioff+ioffinc
- end if
-5 continue
-c
-c Shift level to avoid slur. Conditions are
-c 1. There is a slur
-c 2. No user-defined orn height shift (btest(iornq,25))
-c 3. upslur (islhgt>0)
-c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737
-c 5. islhgt+3 >= height already computed.
-c
- if (.not.btest(iornq,25) .and.
- * islhgt.gt.0 .and. iand(iornt,30737).eq.0)
- * ioff = ioff+dim(islhgt+3,ihorn )
- call notefq(noteq,lnoten,ihorn+ioff,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
- if (iand(iornt,32896) .gt. 0) then
-c
-c T-trill or trill w/o "tr"
-c
- call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote)
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- if (iudorn .gt. 0) then
- if (btest(kudorn(iudorn),31)) then
-c
-c Horizontal shift
-c
- lform = lfmt1(ornhshft(iudorn))
- write(noteq(1:lform),'(f'//chax(48+lform)//'.1)')
- * ornhshft(iudorn)
- notexq = sq//'roffset{'//noteq(1:lform)//'}{'
- * //notexq(1:lnote)//'}'
- lnote = lnote+lform+12
- ornhshft(iudorn) = 0.
- kudorn(iudorn) = ibclr(kudorn(iudorn),31)
- end if
- end if
-c
-c Zero out the bit for ornament just dealt with.
-c
- iornq = ibclr(iornq,ibit)
- if (lout .eq. 0) then
- outq = notexq(1:lnote)
- else
- outq = outq(1:lout)//notexq(1:lnote)
- end if
- lout = lout+lnote
-c
-c Check bits 0-21, go back if any are still set
-c
- if (iand(iornq,4194303) .gt. 0) go to 2
- if (usehornb) nornb(ivx) = nornb(ivx)+1
- return
- end
- subroutine putshft(ivx,onoff,soutq,lsout)
- parameter (nm=24)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- character*80 soutq,notexq
- character*1 sq,chax
- logical onoff
- sq = chax(92)
-c
-c Start user-defined offsets X(...): or X(...)S
-c
- if (onoff) nudoff(ivx) = nudoff(ivx)+1
-c
-c Xoff is in pts. Round off to nearest .1. Will use at end of shift.
-c
- xoff = udoff(ivx,nudoff(ivx))
- xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff)
- if (.not.onoff) xoff = -xoff
- if (xoff .lt. -9.95) then
- ifmt = 5
- else if (xoff.lt.-.95 .or. xoff.gt.9.95) then
- ifmt = 4
- else
- ifmt = 3
- end if
- write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff
- call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt,
- * soutq,lsout)
- return
- end
- subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc,
- * etacs1,nv,vshrink,sepsymq)
-c
-c Called once per page, at top of page! If vshrink, only called for p.1.
-c Actual titles only allowed on p.1. (set by headlog).
-c 3/18/01: The above comment is probably bogus...can use Tt on later pages.
-c
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- character*127 notexq
- character*120 instrq,titleq,compoq
- parameter (nm=24)
- character*1 sq,sepsymq(nm),chax
- logical headlog,vshrink
- notexq = sq//'znotes'
- lenline = 7
- do 22 iv = 1 , nv-1
- notexq = notexq(1:lenline)//sepsymq(iv)
- lenline = lenline+1
-22 continue
- notexq = notexq(1:lenline)//sq//'zcharnote{'
- lenline = lenline+11
- if (.not.headlog) then
- inhead = inhnoh
- end if
- if (vshrink .and. usevshrink) then
- inhead = 16
- end if
- ndig = int(alog10(inhead+.01))+1
- write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)//
- * ',a10)')inhead,'}{'//sq//'titles{'
- lenline = lenline+ndig+10
-c
-c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether
-c headers are present or not.
-c
- glueil = xnsttop/etatop
- vskil = etatop*glueil
- if (vshrink .and. usevshrink) vskil = 2
- call writflot(vskil,notexq,lenline)
- if (.not.headlog) then
- if (islast) write(11,'(a)')notexq(1:lenline)
- * //'}{}{0}{}{0}{}{0}}'//sq//'en%'
- else
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- lcq = lenstr(instrq,120)
- if (lcq .gt. 0) then
- xitil = etait*glueil
- if (vshrink .and. usevshrink) xitil = 2
- notexq = notexq(1:lenline)//instrq(1:lcq)//'}{'
-c
-c Null out instrument once used
-c
- instrq = ' '
- lenline = lenline+lcq+2
- call writflot(xitil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}%'
- notexq = '{'
- lenline = 1
- lcq = lenstr(titleq,120)
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//titleq(1:lcq)
- lenline = lenline+lcq
- else
- call printl(' ')
- call printl('WARNING')
- call printl(
- * ' In a title block, you have specified instrument and/or')
- call printl(
- * ' composer but no title for the piece.')
- end if
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- xtcil = etatc*glueil
- lcq = lenstr(compoq,120)
- if (lcq .eq. 0) xtcil = 2*xtcil
- if (vshrink .and. usevshrink) xtcil = 2
- call writflot(xtcil,notexq,lenline)
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//compoq(1:lcq)//'}{'
- lenline = lenline+2+lcq
-c
-c Null out compoq so it does not get written later
-c
- compoq = ' '
- xcsil = etacs1*glueil
- if (vshrink .and. usevshrink) xcsil = 2
- call writflot(xcsil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%'
- headlog = .false.
- end if
- return
- end
- subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom,
- * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum,
- * eloff,iup,irest,usexnumt)
-c
-c Places digit for xtuplet.
-c
- character*1 chax
- character*8 noteq
- character*79 notexq
- logical btest,usexnumt
- if (iflop.ne.0 .and. multb.gt.0) then
-c
-c Number goes on beam side, move R/L by .5 wheadpt for upper/lower
-c
- eloff = eloff-0.5*iud*wheadpt/poenom
-c
-c Number goes on beam side, must use beam parameters to set pos'n
-c
- nlnum = nolev1+islope/slfac*eloff+iup*(multb+8)
- if (multb .ge. 2) nlnum = nlnum+iup
- else
- nlnum = nint(xnlmid-1+3*iud+iflop*11)
- end if
- if (.not.btest(islur,31)) then
-c
-c Only print number when wanted. First check vert, horiz offset
-c
- if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16
- if (btest(irest,7)) eloff = eloff+
- * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom
- if (.not.usexnumt) then
- notexq = chax(92)//'xnum{'
- lnote = 10
- istrtn = 7
- else
- notexq = chax(92)//'xnumt{'
- lnote = 11
- istrtn = 8
- end if
- if (eloff .lt. 0.995) then
- write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff
- else if (eloff .lt. 9.995) then
- write(notexq(istrtn:istrtn+3),'(f4.2)')eloff
- else
- write(notexq(istrtn:istrtn+4),'(f5.2)')eloff
- lnote = lnote+1
- end if
- call notefq(noteq,lnoten,nlnum,ncmid)
- notexq = notexq(1:lnote)//'}'//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- if (ntupv .lt. 10) then
- write(notexq(lnote+1:lnote+1),'(i1)')ntupv
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//'{'
- write(notexq(lnote+2:lnote+3),'(i2)')ntupv
- notexq = notexq(1:lnote+3)//'}'
- lnote = lnote+4
- end if
- end if
- return
- end
- subroutine read10(string,lastchar)
- parameter (maxblks=4000)
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*(*) string
- character*128 lnholdq
- logical lastchar
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- if (.not.mplay) then
- if (ilbuf .gt. nlbuf) go to 999
- call getbuf(string)
- return
-999 lastchar = .true.
- return
- else
-c
-c Play a macro. Set pointer to first character needed in buffer
-c
- if (ilmac .eq. il1mac(macnum)) then
-c
-c Getting first line of macro
-c
- ip1 = ip1mac(macnum)
- iplmac = ip1-ic1mac(macnum)
- else if (ilmac .le. il2mac(macnum)) then
-c
-c Beyond first line of macro. Advance line-start pointer.
-c
- iplmac = iplmac+lbuf(ilmac-1)
- ip1 = iplmac+1
- else
-c
-c Beyond last line of macro. Terminate it!
-c
- mplay = .false.
- endmac = .true.
- return
- end if
- if (ilmac .eq. il2mac(macnum)) then
-c
-c Getting last line of macro.
-c
- ip2 = ip2mac(macnum)
- else
-c
-c Getting line before last line of macro.
-c
- ip2 = iplmac+lbuf(ilmac)
- end if
- if (ip2 .ge. ip1) then
- string = bufq(ip1:ip2)
- else
-c
-c Kluge for when macro start is on a line by itself
-c
- string = ' '
- end if
- ilmac = ilmac+1
- return
- end if
- end
- function readin(lineq,iccount,nline)
-c
-c Reads a piece of setup data from file lineq, gets a new lineq from
-c file 10 (jobname.pmx) and increments nline if needed, passes over
-c comment lines
-c
- character*128 lineq
- character*1 durq,chax
-4 if (iccount .eq. 128) then
-1 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 1
- iccount = 0
- end if
- iccount = iccount+1
-c
-c Find next non-blank or end of line
-c
- do 2 iccount = iccount , 127
- if (lineq(iccount:iccount) .ne. ' ') go to 3
-2 continue
-c
-c If here, need to get a new line
-c
- iccount = 128
- go to 4
-3 continue
-c
-c iccount now points to start of number to read
-c
- i1 = iccount
-5 call getchar(lineq,iccount,durq)
-c
-c Remember that getchar increments iccount, then reads a character.
-c
- if (index('0123456789.-',durq) .gt. 0) go to 5
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin
- return
- end
- subroutine readmeter(lineq,iccount,mtrnum,mtrden)
- character*128 lineq
- character*1 durq,chax
- if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then
-c
-c No slashes, so use old method
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. '-') then
-c
-c Negative numerator is used only to printed; signals vertical slash
-c
- call getchar(lineq,iccount,durq)
- mtrnum = -(ichar(durq)-48)
- else if (durq .eq. 'o') then
-c
-c Numerator is EXACTLY 1
-c
- mtrnum = 1
- else
- mtrnum = ichar(durq)-48
- if (mtrnum .eq. 1) then
-c
-c Numerator is >9
-c
- call getchar(lineq,iccount,durq)
- mtrnum = 10+ichar(durq)-48
- end if
- end if
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'o') then
- mtrden = 1
- else
- mtrden = ichar(durq)-48
- if (mtrden .eq. 1) then
- call getchar(lineq,iccount,durq)
- mtrden = 10+ichar(durq)-48
- end if
- end if
- else
-c
-c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm'
-c
- iccount = iccount+1
- ns = index(lineq(iccount:128),'/')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum
-c
-c Reset iccount to start of second integer
-c
- iccount = iccount+ns
-c
-c There must be either a slash or a blank at pos'n 2 or 3
-c
- ns = index(lineq(iccount:iccount+2),'/')
- if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden
-c
-c Set iccount to last character used
-c
- iccount = iccount+ns-1
- end if
- return
- end
- subroutine readnum(lineq,iccount,durq,fnum)
-c
-c This reads a number starting at position iccount. Remember that on exit,
-c getchar leaves iccount at the last character retrieved. So must only
-c call this routine *after* detecting a number or decimal.
-c On exit, durq is next character after end of number.
-c
- character*128 lineq
- character*1 durq,chax
- i1 = iccount
-1 call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .gt. 0) go to 1
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then
- i2 = i2-1
- iccount = iccount-1
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum
- return
- end
- subroutine setbits(isdata,iwidbit,ishift,ivalue)
-c
-c Sets iwidbits of isdata, shifted by ishift, to ivalue
-c
- ibase = 2**iwidbit-1
- if (ivalue.gt.ibase) then
- print*
- print*,'WARNING in setbits: ivalue > ibase'
- write(15,'(/,a)')'WARNING in setbits: ivalue > ibase'
- end if
- isdata = iand(not(ishft(ibase,ishift)),isdata)
- isdata = ior(isdata,ishft(ivalue,ishift))
- return
- end
- subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
-c
-c The MEAN SQUARE slope algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig
- real*4 xelsk(24)
- integer ipb(24)
- ibc = ibmcnt(ivx)
- sumxx = 0.
- sumxy = 0.
- do 2 inb = 1 , nnb
- sumxx = sumxx+xelsk(inb)**2
- sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb))
-2 continue
- delta = nnb*sumxx-sumx*sumx
- em = (nnb*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*slfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/slfac*sumx)/nnb
- nolev1 = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- do 4 inb = 1 , nnb
- ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
- ynote = nolev(ivx,ipb(inb))
- smin = min(smin,iul*(ybeam-ynote))
-4 continue
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolev1 = nint(nolev1+iul*deficit)
- end if
- return
- end
- subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,
- * ivx,nline)
- character*1 charq,durq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,btest
- character*128 lnholdq,lineq
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
-c
-c Macro action
-c
- call g1etchar(lineq,iccount,charq)
- if (charq.eq.'S' .and. ivx.ne.1) then
- print*
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"MS..." only put in parts by scor2prt if in voice #1!')
- end if
- if (index('RSP ',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "M" (macro)!')
- call stop1()
- else if (charq .ne. ' ') then
-c
-c Record or playback a macro. Get the number of the macro.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must input number after "MR","MP", or "MS"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macro number must be followed by a blank!')
- call stop1()
- end if
- if (index('RS',charq ).gt. 0) then
-c
-c Record or save a macro
-c
- if (macnum.lt.1 .or. macnum.gt.20) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Macro number not in range 1-20!')
- call stop1()
-c else if (btest(macuse,macnum)) then
-c print*
-c print*,'WARNING: Redefining macro # ',macnum
- end if
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- else if (charq .eq. 'S') then
-c
-c Save (Record but don't activate)
-c
-1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- nline = nline+1
- iccount = 0
- go to 1
- end if
- iccount = iccount+ndxm+1
- end if
- else
-c
-c Playback the macro
-c
- if (.not.btest(macuse,macnum)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a macro that has not been recorded!')
- call stop1()
- end if
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- mplay = .true.
- ilmac = il1mac(macnum)
- end if
- end if
- return
- end
- subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
-c
-c Sets last 2 args depending on 1st 2, (logical) num, denom.
-c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings.
-c 1: all duple meters
-c 2: triple w/ denom=4, subdivide in groups of 2 8ths
-c 3: triple w/ denom=8, subdivide in groups of 3 8ths
-c Note that lenbar is set at top or when 'm' symbol is read in getnote
-c
- if (mtrdenl .eq. 4) then
- if (mod(mtrnuml,3) .eq. 0) then
- ibmtyp = 2
- ibmrep = mtrnuml/3
- else
- ibmtyp = 1
- ibmrep = mtrnuml/2
- end if
- else if (mtrdenl .eq. 2) then
- ibmtyp = 1
- if (mtrnuml .eq. 3) then
- ibmrep = 3
- else
- ibmrep = 2*mtrnuml/mtrdenl
- end if
- else
-c
-c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8
-c
- ibmtyp = 3
- ibmrep = mtrnuml/3
- end if
-c
-c Reset so we don't keep writing new meters
-c
- mtrnuml = 0
-c
-c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter
-c
- ibmrep = max(ibmrep,1)
- return
- end
- subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest)
-c
-c The outer combo algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm
- common /comeskz2/ eskz2(nm,200)
- real*4 slope(800),xelsk(24)
- integer ipb(24)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xels11(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- ibc = ibmcnt(ivx)
- nxtinbm(ivx) = 0
- n1 = ipl2(ivx,ibm1(ivx,ibc))
-c
-c Initialize counters used in this subroutine, and then later during actual
-c beam drawing, to count later segments of single-slope beam groups
-c
- nssb(ivx) = 0
- issb(ivx) = 0
-c
-c Set flag for xtup beam starting with rest (no others can start with rest)
-c
- if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1
-c
-c Figure how many elemskips to each note. Use the list, counting only non-rests.
-c
- eskz0 = eskz(ivx,ibm1(ivx,ibc))
- nnb = 0
- sumx = 0.
- sumy = 0.
- ipxt1 = 0
- iplast = ibm2(ivx,ibc)
- do 2 ip = ibm1(ivx,ibc) , iplast
- if (.not.btest(irest(ivx,ip),0)) then
- nnb = nnb+1
- ipb(nnb) = ip
- xelsk(nnb) = eskz(ivx,ip)-eskz0
- sumx = sumx+xelsk(nnb)
- sumy = sumy+nolev(ivx,ipb(nnb))
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is the starting note of later segment of single-slope beam group
-c Temporarily store ip here.
-c
- nssb(ivx) = nssb(ivx)+1
- lev1ssb(ivx,nssb(ivx)) = nnb
- end if
- end if
-c
-c New xtup stuff here. Final object is to get distance from start of xtup
-c to number. xtinbm counts xtups in this beam only. mtupv is the printed
-c number. ntupv is number of notes in xtup, and is only used to get
-c eloff, the distance from start of xtup to the number.
-c
- if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1
- if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then
-c
-c Xtup is starting here
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- ipxt1 = ip
- if (btest(nacc(ivx,ip),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
- else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then
-c
-c Xtup ends here. Set total number of notes in xtup.
-c
- ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1
-c
-c Set printed number for embedded xtup.
-c
- mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub
-c
-c Middle note of xtup if ntupv odd, note to left of gap if even.
-c
- ipxtmid = (ip+ipxt1)/2
- eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0)
- * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+
- * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid))
- ipxt1 = 0
- end if
-2 continue
-c
-c Reset nxtinbm for use as counter as #'s are posted by putxtn(..)
-c
- nxtinbm(ivx) = 0
- smed = 0.
- if (.not.btest(islur(ivx,ipb(1)),2)) then
-c
-c No forced 0 slope
-c
- if (nnb .eq. 1) go to 6
- nsc = 0
- do 5 inb = 1 , nnb-1
- do 5 jnb = inb+1 , nnb
- nsc = nsc+1
- slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/
- * (xelsk(jnb)-xelsk(inb))
- if (abs(slope(nsc)) .lt. 1.e-4) then
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- end if
-5 continue
- if (nsc .eq. 1) then
- smed = slope(1)
- go to 6
- end if
- nscmid = nsc/2+1
- do 7 i = 1 , nscmid
- do 7 j = i+1 , nsc
- if (slope(j) .lt. slope(i)) then
- t = slope(j)
- slope(j) = slope(i)
- slope(i) = t
- end if
-7 continue
- smed = slope(nscmid)
- if (nsc .eq. 2*(nsc/2)) then
-c
-c Even number of slopes in the list, so median is ambiguous
-c
- if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then
-c
-c Lower-numbered one is truly less in absolute value, so use it
-c
- smed=slope(nscmid-1)
- else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then
-c
-c Two slopes are effectively equal. Take the one with sign of the average
-c
- sum = 0.
- do 1 i = 1 , nsc
- sum = sum+slope(i)
-1 continue
- smed = sign(smed,sum)
- end if
- end if
-6 continue
- islope(ivx) = nint(0.5*smed*slfac)
- if (iabs(islope(ivx)) .gt. 9)
- * islope(ivx) = isign(9,islope(ivx))
- else
-c
-c Forced horizontal beam
-c
- islope(ivx) = 0
- end if
- beta = (sumy-islope(ivx)/slfac*sumx)/nnb
-c
-c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use
-c as is for placing xtup number and/or bracket, then reset it for start of
-c actual beam
-c
- nolev1(ivx) = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- ssq = 0.
- syb = 0.
-c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1))
- yb1 = nolev1(ivx)
- * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1))
- do 4 inb = 1 , nnb
- ybeam = yb1+islope(ivx)*xelsk(inb)/slfac
-c * -iul*bmhgt*(mult(ivx,ipb(inb))-1)
- * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1)
- syb = syb+ybeam
- ynote = nolev(ivx,ipb(inb))
- off = ybeam-ynote
- if (inb .eq. 1) then
- off1 = off
- else if (inb .eq. nnb) then
- off2 = off
- end if
- ssq = ssq+off*off
- smin = min(smin,iul*off)
-4 continue
- dnolev = 0.
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolevo = nolev1(ivx)
- nolev1(ivx) = nint(nolev1(ivx)+iul*deficit)
- dnolev = nolev1(ivx)-nolevo
- off1 = off1+dnolev
- off2 = off2+dnolev
- end if
- ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
- if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and.
- * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)
- * .and. .not.btest(islur(ivx,ipb(1)),2)) then
-c
-c The first check is to save trouble of putting xtup's in setbm2.
-c The penultimate check is that first and last stems aren't both excessive.
-c The last check is that a 0 slope has not been forced
-c
- call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx))
- end if
-c
-c Check if beam starts or ends too high or low.
-c
-c xboff = bmhgt*(mult(ivx,ipb(1))-1)
- xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)
- l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0.
- xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb)
- l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0
- if (l1ng .or. l2ng) then
-c
-c Need to correct start or stop, also slope
-c
- if (l1ng) then
- nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul)
- end if
- if (l2ng) then
- xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul)
- end if
-c
-c Since one or the other end has changed, need to change slope
-c
- if (.not.btest(islur(ivx,ipb(1)),2))
- * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb))
- end if
- if (nssb(ivx) .gt. 0) then
-c
-c This is a single-slope beam group. Store start heights for later segs.
-c
- do 3 issbs = 1 , nssb(ivx)
- lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac*
- * xelsk(lev1ssb(ivx,issbs))
-3 continue
- end if
- return
- end
- subroutine sortpoe(nsyst,poe,ipoe)
- parameter (nks=125)
- real*4 poe(nks)
- integer*4 ipoe(nks)
-c
-c Initialize ipoe:
-c
- do 3 iord = 1 , nsyst
- ipoe(iord) = iord
-3 continue
-c
-c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will
-c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe.
-c
- do 4 io1 = 1 , nsyst-1
- do 5 io2 = io1+1 , nsyst
- if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then
-c
-c Interchange the indices
-c
- itemp = ipoe(io1)
- ipoe(io1) = ipoe(io2)
- ipoe(io2) = itemp
- end if
-5 continue
-4 continue
- return
- end
- subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 This subr is called ONLY for postscript slurs.
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
- isdat4(nsdat) = 0
- ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur
-c
-c Get ID code
-c
- call getchar(lineq,iccount,durq)
- if (index('uldtb+-hfnHps ',durq) .gt. 0) then
-c
-c Null id. Note for ps slurs, 'H' cannot be an ID
-c
- iccount = iccount-1
- if (lineq(iccount:iccount) .eq. 't') then
- idcode = 1
- else
- idcode = 32
- end if
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- if (lineq(iccount-1:iccount-1) .eq. 't') then
-c
-c Make t[ID] look like s[ID]t
-c
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics.
-c
- if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then
-c
-c There's a default curvature tweak
-c
- icurv1 = nint(SlurCurve)+3
- if (icurv1 .eq. 2) icurv1 = 1
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- end if
-c
-c Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (durq .eq. 's') then
-c
-c Endpoint tweaks for linebreak slurs.
-c
- call getchar(lineq,iccount,durq) ! Must be +|-
-c
-c Next is vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32)
- if (index('+-',dumq) .gt. 0) then
-c
-c Also a horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64)
- end if
- iccount = iccount-1
- ilb12 = 1
- go to 1
- else if (index('fnhH',durq).gt.0) then
-c
-c Special ps slur curvatures.
-c Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = index('fnxhH',durq)
- if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- else if (durq .eq. 'p') then ! Local adjustment
- call getchar(lineq,iccount,durq) ! +|-
- call getchar(lineq,iccount,dumq) ! s|t
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
- if (durq .eq. '+') then
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),26)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),28)
- end if
- else
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),27)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),29)
- end if
- end if
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
-c
-c Get id letter
-c
- if (lineq(iccount:iccount) .eq. 't') then
-c
-c Old-style t-slur. Use special idcode = 1
-c
- idcode = 1
- else
- call getchar(lineq,iccount,durq)
- if (index('uldtb+-hf ',durq) .gt. 0) then
-c
-c Null id
-c
- idcode = 32
- iccount = iccount-1
- else if (durq.eq.'H') then
-c
-c Postscript slur, cannot use 'H' as code, must check for 2nd 'H'
-c
- idcode = 32
- iccount = iccount-1
-c
-c There may be another "H", but no need to deal with it yet
-c
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics. Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (index('fhH',durq) .gt. 0) then
-c
-c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = 2+index('fhH',durq)
- if (icurv1 .eq. 3) then
- icurv1 = 1
- else if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
-c
-c Must change sign if downslur, but cannot do it now since we don't know
-c slur direction for sure.
-c
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine stop1()
- call exit(1)
- end
- subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink,fontslur
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*79 inameq
- character*44 basenameq
- character*24 fmtq
- character*5 fbarq
- character*1 clefq(nm),sq,chax
- common /comstart/ facmtr
- logical vshrink,lowdot,rename
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
- sq = chax(92)
- vshrink = xinstf1.gt.20. .and. .not.novshrinktop
- if (vshrink) then
- xinsnow = 10.
- else
- xinsnow = xinstf1
- end if
- if (.not.islast) return
- write(11,'(a)')'%%%%%%%%%%%%%%%%%'
- write(11,'(a)')'%'
- write(11,'(a)')'% '//basenameq(1:lbase)//'.tex'
- write(11,'(a)')'%'
- write(11,'(a)')'%%%%%%%%%%%%%%%%'
- write(11,'(a)')sq//'input musixtex'
- write(11,'(a)')sq//'input pmx'
-c write(11,'(a)')sq//'input musixmad'
-c write(11,'(a)')sq//'input musixxad'
- write(11,'(a)')
- * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%'
- if (.not.fontslur) write(11,'(a)')sq//'input musixps'
-c
-c Need to input musixmad to permit more slurs.
-c
- if (musicsize .eq. 20) then
- write(11,'(a)')sq//'normalmusicsize%'
- else if (musicsize .eq. 16) then
- write(11,'(a)')sq//'smallmusicsize%'
- else if (musicsize .eq. 24) then
- write(11,'(a)')sq//'largemusicsize%'
- write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
- * 'meterlargefont}%'
- else if (musicsize .eq. 29) then
- write(11,'(a)')sq//'Largemusicsize%'
- write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
- * 'meterLargefont}%'
- end if
-c
-c Set sizes. Have sizes per staff in isize(.) and noinst per staff in
-c nsperi(.)
-c
- iiv = 1
- do 5 iinst = 1 , noinst
- if (isize(iiv) .eq. 1) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'smallvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'smallvalue%'
- end if
- else if (isize(iiv) .eq. 2) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'tinyvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'tinyvalue%'
- end if
- end if
- iiv = iiv+nsperi(iinst)
-5 continue
-c
-c do 5 iiv = 1 , nv
-c if (isize(iiv) .eq. 1) then
-c if(iiv.le.9) then
-c write(11,'(a8,i1,a)')
-c * sq//'setsize',iiv,sq//'smallvalue%'
-c else
-c write(11,'(a9,i2,a)')
-c * sq//'setsize{',iiv,'}'//sq//'smallvalue%'
-c end if
-c else if (isize(iiv) .eq. 2) then
-c if(iiv.le.9) then
-c write(11,'(a8,i1,a)')
-c * sq//'setsize',iiv,sq//'tinyvalue%'
-c else
-c write(11,'(a9,i2,a)')
-c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%'
-c end if
-c end if
-c5 continue
-c
- write(fbarq,'(f5.3)')fbar
- write(11,'(a)')sq//'nopagenumbers'
- write(11,'(a)')sq//'tracingstats=2'//sq//'relax'
- write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt'
- write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)')
- * sq//'vsize',int(height+.1),'pt'
-c
-c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if
-c 3 sharps and treble clef, to avoid vertical clash with top space g#
-c
- if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)')
- * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}'
- if (noinst .lt. 10) then
- write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- else
- write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- end if
- iv = 0
- do 1 iinst = 1 , noinst
- nstaves = nsperi(iinst)
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setstaffs'//chax(48+iinst)
- * //chax(48+nstaves)
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}'
- * //chax(48+nstaves)
- end if
- iv = iv+1
- if (nstaves .eq. 1) then
- fmtq = chax(48+numclef(clefq(iv)))
- lfmtq = 1
- else
- fmtq = '{'//chax(48+numclef(clefq(iv)))
- lfmtq = 2
- do 2 k = 2 , nstaves
- iv = iv+1
- fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv)))
- lfmtq = lfmtq+1
-2 continue
- fmtq = fmtq(1:lfmtq)//'}'
- lfmtq = lfmtq+1
- end if
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq)
- else
- write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq)
- end if
- do 3 lname = 79 , 2 , -1
- if (inameq(iinst)(lname:lname) .ne. ' ') go to 4
-3 continue
-4 continue
- lnam(iinst) = lname
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,
- * '{'//inameq(iinst)(1:lname)//'}'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,
- * '}{'//inameq(iinst)(1:lname)//'}'
- end if
-1 continue
- write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%'
- if (EarlyTransOn)
- * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn)
- call wgmeter(mtrnmp,mtrdnp)
- ipi = nint(fracindent*widthpt)
- if (ipi .lt. 10) then
- write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip'
- * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax'
- if (.not.vshrink) then
- if (xinstf1 .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt'
- * //sq//'interstaff{',xinstf1,'}'//sq//'relax'
- else
- write(11,'(a)')sq//'stafftopmarg0pt'//
- * sq//'staffbotmarg5'//sq//'Interligne'//sq//
- * 'interstaff{10}'//sq//'relax'
- end if
- if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
- write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
- if (cstuplet) then
- write(11,'(a)')sq//'input tuplet'
- * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}'
- * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}'
- * //sq//'/'//sq//'/}}%'
- write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet'
- * //sq//'let'//sq//'unbkt'//sq//'downtuplet%'
- end if
- write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq//
- * 'addspace'//sq//'afterruleskip%'
- return
- end
- character*1 function udfq(nolev,ncm)
-c
-c Slur directions
-c
- common /combc/ bcspec
- logical bcspec
- ntest = nolev-ncm
- if (ntest.lt.0 .or.
- * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then
- udfq = 'd'
- else
- udfq = 'u'
- end if
- return
- end
- character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv)
-c
-c Stem direction for single notes
-c
- character*1 ulfq
- character*1 udqqq
- logical btest
- if (btest(isl,30)) then
-c
-c Absolute override
-c
- if (btest(isl,17)) then
- udqqq = 'u'
- else
- udqqq = 'l'
- end if
- else if (nvmx .eq. 1) then
-c
-c Single voice per staff, default
-c
- udqqq = ulfq(1.*nole,ncm)
- else
-c
-c Multi-voice per staff, 1st is lower, 2nd upper
-c
- if (ivx .le. nv) then
- udqqq = 'l'
- else
- udqqq = 'u'
- end if
- end if
- udqq = udqqq
- return
- end
- character*1 function ulfq(xnolev,ncm)
-c
-c Stem directions
-c
- common /combc/ bcspec
- logical bcspec
- test = xnolev-ncm
- if (test.lt.-.001 .or.
- * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then
- ulfq = 'u'
- else
- ulfq = 'l'
- end if
- return
- end
- function upcaseq(chq)
- character*1 chq,upcaseq,chax
- if (ichar(chq).ge.61.and.ichar(chq).lt.122) then
- upcaseq = chax(ichar(chq)-32)
- else
- upcaseq = chq
- print*,'Warning, upcaseq was called with improper argument: '
- * //chq
- stop
- end if
- return
- end
- subroutine wgmeter(mtrnmp,mtrdnp)
-c
-c Writes meter stuff to file 11, so only called if islast=.true.
-c
- character*1 sq,chax
- if (mtrdnp .eq. 0) return
- sq=chax(92)
- if (mtrnmp.gt.0 .and. mtrnmp.le.9) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i1,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .ge. 10) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i2,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i2,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .lt. 0) then
- write(11,'(a26,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfracS{',
- * -mtrnmp,'}{',mtrdnp,'}}%'
- else if (mtrdnp .le. 4) then
- write(11,'(a21,i1,a2)')
- * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%'
- else if (mtrdnp .eq. 5) then
- write(11,'(a)')sq//'generalmeter'//sq//'allabreve%'
- else if (mtrdnp .eq. 6) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterC%'
- else if (mtrdnp .eq. 7) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%'
- end if
- return
- end
- subroutine writemidi(jobname,ljob)
- parameter(nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- character*1 byteq(4),char,chax
- character*10 tempoq,instq
- character*44 jobname
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- logical rename
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
-c
-c Used to be icmm(0:nm); did midi fail when nv>16?
-c
- integer*2 iinsiv(nm),icmm(0:15)
- character*5 versionc
- common /comver/ versionc
-c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c Can't remember why these were not consecutive.
-c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/
-c
-c Write Header
-c
- write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6)
- * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240)
- if (debugmidi)
- * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6,
- * 0,1,0,numchan+1,0,240
-c
-c Write the "conductor" track, for keys, meter, and tempos
-c Get the number of bytes in the conductor event stream
-c
- ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec)
- do 15 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec)
-15 continue
-c ib1 = (4+ljob+26+ndata+4)/256
-c ib0 = 4+ljob+26+ndata+4-256*ib1
- ib1 = (4+ljob+27+ndata+4)/256
- ib0 = 4+ljob+27+ndata+4-256*ib1
- write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0)
-c
-c Text header
-c
-c * //char(0)//char(255)//char(1)//char(ljob+26)
- * //char(0)//char(255)//char(1)//char(ljob+27)
- if (debugmidi)
- * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0,
- * 0,255,1,ljob+27
- write(51,'(a,$)')jobname(1:ljob)
- if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"'
-c
-c (separate writes are needed to defeat compiler BUG!!!)
-c
-c write(51,'(a,$)')'.mid, produced by PMX 2.30'
- write(51,'(a,$)')'.mid, produced by PMX '//versionc
- if (debugmidi) write(52,'(a)')
- * '".mid, produced by PMX '//versionc//'"'
-c
-c Conductor event data: Loop over sections.
-c
- do 16 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(numchan,isec)
- else
- mend = imidi(numchan)
- end if
- do 17 i = msecstrt(numchan,isec) , mend
- write(51,'(a,$)')char(mmidi(numchan,i))
- if (debugmidi) write(52,'(z4)')mmidi(numchan,i)
-17 continue
-16 continue
-c
-c And close out the time sig / tempo track.
-c
- write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
-c
-c Loop over track for each voice: The following sets up iv.
-c
- iv = nv
- if (twoline(nv)) then
- kv = 2
- else
- kv = 1
- end if
-c
-c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv)
-c
- nstaves = 0
- ivt = 0
- do 12 iinst = 1 , nm
- nstaves = nstaves+nsperi(iinst)
- do 13 ivtt = 1 , nsperi(iinst)
- ivt = ivt+1
- iinsiv(ivt) = iinst
-13 continue
- if (nstaves .eq. nv) go to 14
-12 continue
- print*,'Screwup!'
- call stop1()
-14 continue
-c
- do 5 icm = 0 , numchan-1
-c
-c Get the number of bytes in the data stream
-c
- ndata = 1+imidi(icm)-msecstrt(icm,nmidsec)
- do 11 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec)
-11 continue
-c
-cc Add 3 (for instrum) plus 4 (for closing) to byte count,
-c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count,
-c
-c ndata = ndata+7
- ndata = ndata+11
-c
-c Add 4+lnam(iinsiv(iv)) if lnam>0 ,
-c
- if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv))
-c
-c Separate total byte counts into 4 bytes
-c
- do 2 ibyte = 1 , 4
- if (ndata .gt. 0) then
- byteq(ibyte) = char(mod(ndata,256))
- ndata = ishft(ndata,-8)
- else
- byteq(ibyte) = char(0)
- end if
-2 continue
-c
-c Now write front stuff for this track
-c
- write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1)
- * //char(0)//char(12*16+icmm(icm))//char(midinst(iv))
- * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm))
- if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm,
- * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)),
- * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv),
- * 0,11*16+icmm(icm),10,midbc(icm)
- if (lnam(iinsiv(iv)) .gt. 0) then
-c
-c Add instrument name as sequence name
-c
- write(51,'(a,$)')char(0)//char(255)//char(3)
- * //char(lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv))
- write(51,'(a,$)')
- * inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(a)')
- * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"'
- end if
- write(tempoq,'(i2)')icm
- write(instq,'(i3)')midinst(iv)
- call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3))
-c
-c Notes: Loop over sections.
-c
- do 9 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(icm,isec)
- else
- mend = imidi(icm)
- end if
- do 10 i = msecstrt(icm,isec) , mend
- write(51,'(a,$)')char(mmidi(icm,i))
- if (debugmidi) write(52,'(z4)')mmidi(icm,i)
-10 continue
-9 continue
-c
-c Closing 4 bytes
-c
- write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
- if (kv .eq. 2) then
- kv = 1
- else if (iv .eq. 1) then
- go to 5
- else
- iv = iv-1
- if (twoline(iv)) kv=2
- end if
-5 continue
- write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan)
- write(15,'(1x,a12,(10i6))')
- * 'Bytes used:',(imidi(icm),icm=0,numchan)
- close(51)
- if (debugmidi) close(52)
- return
- end
- subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag)
- parameter(nm=24)
- integer*4 iInstTrans(nm),iTransKey(nm)
- character*79 notexq
- character*1 chax
- logical flag
-c
-c Assumes notexq is blank
-c
- do 1 i = 1 , nInstTrans
- notexq = chax(92)//'setsign'
- lnote = 8
- if (iInstTrans(i) .lt. 10) then
- notexq = notexq(1:lnote)//chax(48+iInstTrans(i))
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iInstTrans(i),'}'
- lnote = lnote+4
- end if
- if (iTransKey(i) .lt. 0) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iTransKey(i),'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+iTransKey(i))
- lnote = lnote+1
- end if
- write(11,'(a)')notexq(1:lnote)//'%'
-1 continue
- flag = .false.
- return
- end
- subroutine writflot(x,notexq,lenline)
- character*(*) notexq
- if (x .lt. 0.95) then
- write(notexq(lenline+1:lenline+2),'(f2.1)')x
- lenline = lenline+2
- else if (x .lt. 9.95) then
- write(notexq(lenline+1:lenline+3),'(f3.1)')x
- lenline = lenline+3
- else
- write(notexq(lenline+1:lenline+4),'(f4.1)')x
- lenline = lenline+4
- end if
- return
- end
- subroutine wsclef(iv,ninow,clefq,nclef)
-c
-c Writes \setclef for instrument containing voice iv
-c
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- logical rename
- character*1 clefq(nm),chax
- character*20 temq
- if (nclef .lt. 7) then
- clefq(iv) = chax(48+nclef)
- else
- clefq(iv)='9'
- end if
- if (.not.islast) return
- iv1 = 1
- do 1 iinst = 1 , ninow
- if (iv .lt. iv1+nspern(iinst)) go to 2
- iv1 = iv1+nspern(iinst)
-1 continue
- print*
- print*,'Should not be here in wsclef!'
- call stop1()
-2 continue
- iv2 = iv1+nspern(iinst)-1
- if (iinst .lt. 10) then
- temq = chax(92)//'setclef'//chax(48+iinst)
- ltem = 9
- else
- write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}'
- ltem = 12
- end if
- if (iv1 .eq. iv2) then
- write(11,'(a)')temq(1:ltem)//clefq(iv)//'%'
- else
- temq = temq(1:ltem)//'{'
- ltem = ltem+1
- do 3 iiv = iv1 , iv2
- temq = temq(1:ltem)//chax(48+numclef(clefq(iiv)))
- ltem = ltem+1
-3 continue
- write(11,'(a)')temq(1:ltem)//'}%'
- end if
- return
- end
diff --git a/Build/source/utils/pmx/pmx-2.6.17/pmxab.c b/Build/source/utils/pmx/pmx-2.6.17/pmxab.c
deleted file mode 100644
index 763d8505f50..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/pmxab.c
+++ /dev/null
@@ -1,37856 +0,0 @@
-/* pmx2617.f -- 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;
- 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;
- 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[2];
- integer fill_2[127];
- real e_3[30];
- integer fill_4[73];
- } compage_ = { 524.f, 740.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] = "28 Jan 12";
- static char version[5] = "2617 ";
- 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 <http://www.gnu.org/licenses/>. */
-
-
-
-/* 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.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 <blank><blank>/ */
-/* 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 "<blank><blank>/" 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 \"<blank><bl"
- "ank>/\"", (ftnlen)39);
- e_wsle();
- s_wsle(&io___35);
- do_lio(&c__9, &c__1, "Removing last line of \"<blank><bl"
- "ank>/\"", (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, &ltemp, (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, &ltemp, 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 *)&noteqga[i__ - 1] == *(unsigned char *)&
- ch__1[0]) {
- itrans += 7;
- } else /* if(complicated condition) */ {
- chax_(ch__1, (ftnlen)1, &c__96);
- if (*(unsigned char *)&noteqga[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=<imid=<9, no brackets */
-
-/* Writing concatenation */
- i__4[0] = lnote, a__2[0] = notexq;
- *(unsigned char *)&ch__1[0] = imid + 48;
- i__4[1] = 1, a__2[1] = ch__1;
- s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
- ++lnote;
- }
- if (bit_test(isdat3[isdat],1)) {
-
-/* \curve; 3 args */
-
-/* Writing concatenation */
- i__4[0] = lnote, a__2[0] = notexq;
- *(unsigned char *)&ch__1[0] = igetbits_(&isdat3[isdat]
- , &c__3, &c__8) + 48;
- i__4[1] = 1, a__2[1] = ch__1;
- s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
-/* Writing concatenation */
- i__4[0] = lnote + 1, a__2[0] = notexq;
- *(unsigned char *)&ch__1[0] = igetbits_(&isdat3[isdat]
- , &c__3, &c__11) + 48;
- i__4[1] = 1, a__2[1] = ch__1;
- s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79);
- lnote += 2;
- }
- addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)
- 80);
- }
-
-/* Shift slur ending for stem on any note? */
-
- if (! stemup && *(unsigned char *)slurudq == 'd' && *tno <
- 63.f) {
- ihoff += -8;
- }
- if (bit_test(isdat2[isdat],3)) {
-
-/* Shift ending for tie spacing */
-
- if (*(unsigned char *)slurudq == 'u') {
- ihoff += -8;
- --ivoff;
- } else if (*(unsigned char *)slurudq == 'd') {
- ++ivoff;
- if (stemup || *tno > 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 <blank>/", (ftnlen)18);
- e_wsle();
- s_wsle(&io___565);
- do_lio(&c__9, &c__1, "appending <blank>/", (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 != ' ') {
- 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 abdeiINprRsST!", (ftnlen)128, (
- ftnlen)55);
-/* * 'After "A" must follow one of the letters abdeiINprsST!') */
- 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;
- }
-/* if (durq .eq. 'N') then */
- 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, mapnow;
- static logical inxtup[24];
- static integer 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, ptsadd;
- static integer ihshft;
- static real taccfac;
- 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 *), 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), dograce_(integer *, integer *, real *, char *,
- integer *, integer *, integer *, integer *, integer *, logical *,
- logical *, integer *, integer *, integer *, integer *, integer *,
- integer *, real *, char *, ftnlen, ftnlen), beamend_(char *,
- integer *, ftnlen), beamid_(char *, integer *, ftnlen);
- static real tother;
- static integer levtop, iraise1, iraise2, iraise;
- static logical isgrace;
- static integer icashft;
- static real ptbneed;
- static integer levbot, itleft, itendb;
- extern integer iashft_(integer *);
- static integer nolevc, ivlast;
- 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;
- extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen)
- ;
- static integer mtrspc;
- static real wheadpt1;
-
- /* 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. */
-/* <<But if it was xtup. don't need to call eskb4.>>???? */
-
-/* 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;
- static real poenom;
- extern /* Subroutine */ int printl_(char *, ftnlen);
- 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__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<x> */
-
- 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 integer 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, npages, ibcoff;
- static logical istype0;
- static integer ibmrep, nhstot, jprntb, nhssys;
- extern /* Subroutine */ int addmidi_(integer *, integer *, integer *,
- integer *, real *, logical *, logical *), outbar_(integer *,
- integer *);
- static real ptsndb;
- static integer lenbeat;
- static real ptsndv;
- extern /* Subroutine */ int wsclef_(integer *, integer *, char *, integer
- *, ftnlen);
- static integer islnow, iplnow, nbarss;
- 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;
- static real elsktot, xnsttop[40];
- static integer ndigbn;
-
- /* 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__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<hshft<12.8 */
-
-/* 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 (hshft < -9.95f) {
- 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 *)&hshft, (ftnlen)sizeof(real));
- e_wsfi();
- *lnote += 5;
- } else if (hshft < -.05f || hshft > 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, "(a)", 0 };
- static cilist io___1672 = { 0, 11, 0, "(a19,i1,a1)", 0 };
- static cilist io___1673 = { 0, 11, 0, "(a19,i2,a1)", 0 };
- static cilist io___1676 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1677 = { 0, 11, 0, "(a11,i2,a)", 0 };
- static cilist io___1681 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1682 = { 0, 11, 0, "(a9,i2,a)", 0 };
- static cilist io___1684 = { 0, 11, 0, "(a8,i1,a)", 0 };
- static cilist io___1685 = { 0, 11, 0, "(a9,i2,a)", 0 };
- static cilist io___1686 = { 0, 11, 0, "(a18,i2,a2)", 0 };
- static cilist io___1688 = { 0, 11, 0, "(a11,i1,a2)", 0 };
- static cilist io___1689 = { 0, 11, 0, "(a11,i2,a2)", 0 };
- static cilist io___1690 = { 0, 11, 0, "(a11,i3,a2)", 0 };
- static cilist io___1691 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1692 = { 0, 11, 0, fmtq, 0 };
- static cilist io___1693 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1694 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1695 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1696 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1697 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1698 = { 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();
-
-/* 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___1671);
-/* 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___1672);
-/* 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___1673);
-/* 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___1676);
-/* 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___1677);
-/* 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___1681);
-/* 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___1682);
-/* 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___1684);
-/* 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___1685);
-/* 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___1686);
-/* 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___1688);
-/* 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___1689);
-/* 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___1690);
-/* 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___1691);
-/* 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___1692);
-/* 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___1693);
-/* 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___1694);
-/* 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___1695);
-/* 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___1696);
-/* 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___1697);
-/* 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___1698);
-/* 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___1702 = { 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___1702);
-/* 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___1704 = { 0, 11, 0, "(a25,i1,a2,i1,a3)", 0 };
- static cilist io___1705 = { 0, 11, 0, "(a25,i1,a2,i2,a3)", 0 };
- static cilist io___1706 = { 0, 11, 0, "(a25,i2,a2,i1,a3)", 0 };
- static cilist io___1707 = { 0, 11, 0, "(a25,i2,a2,i2,a3)", 0 };
- static cilist io___1708 = { 0, 11, 0, "(a26,i1,a2,i1,a3)", 0 };
- static cilist io___1709 = { 0, 11, 0, "(a21,i1,a2)", 0 };
- static cilist io___1710 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1711 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1712 = { 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___1704);
-/* 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___1705);
-/* 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___1706);
-/* 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___1707);
-/* 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___1708);
-/* 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___1709);
-/* 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___1710);
-/* 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___1711);
-/* 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___1712);
-/* 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___1714 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1715 = { 0, 52, 0, "(a6,10Z4)", 0 };
- static cilist io___1720 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1721 = { 0, 52, 0, "(a6,8z4)", 0 };
- static cilist io___1722 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1723 = { 0, 52, 0, "(a)", 0 };
- static cilist io___1724 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1725 = { 0, 52, 0, "(a)", 0 };
- static cilist io___1728 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1729 = { 0, 52, 0, "(z4)", 0 };
- static cilist io___1730 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1731 = { 0, 52, 0, "(4z4)", 0 };
- static cilist io___1738 = { 0, 6, 0, 0, 0 };
- static cilist io___1742 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1743 = { 0, 52, 0, "(a4,z2,a7,11z4)", 0 };
- static cilist io___1744 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1745 = { 0, 52, 0, "(4z4)", 0 };
- static cilist io___1746 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1747 = { 0, 52, 0, "(a)", 0 };
- static icilist io___1749 = { 0, tempoq, 0, "(i2)", 10, 1 };
- static icilist io___1751 = { 0, instq, 0, "(i3)", 10, 1 };
- static cilist io___1752 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1753 = { 0, 52, 0, "(z4)", 0 };
- static cilist io___1754 = { 0, 51, 0, "(a,$)", 0 };
- static cilist io___1755 = { 0, 52, 0, "(4z4)", 0 };
- static cilist io___1756 = { 0, 6, 0, "(1x,a12,(10i6))", 0 };
- static cilist io___1757 = { 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___1714);
-/* 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___1715);
- 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___1720);
-/* 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___1721);
- 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___1722);
- do_fio(&c__1, jobname, (*ljob));
- e_wsfe();
- if (commidi_1.debugmidi) {
- s_wsfe(&io___1723);
-/* 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___1724);
-/* 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___1725);
-/* 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___1728);
- *(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___1729);
- 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___1730);
- do_fio(&c__1, "\000\377/\000", (ftnlen)4);
- e_wsfe();
- if (commidi_1.debugmidi) {
- s_wsfe(&io___1731);
- 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___1738);
- 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___1742);
-/* 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___1743);
- 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___1744);
-/* 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___1745);
- 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___1746);
- 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___1747);
-/* 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___1749);
- do_fio(&c__1, (char *)&icm, (ftnlen)sizeof(integer));
- e_wsfi();
- s_wsfi(&io___1751);
- 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___1752);
- *(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___1753);
- 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___1754);
-/* 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___1755);
- 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___1756);
- 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___1757);
- 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___1761 = { 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___1761);
-/* 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___1764 = { 0, 6, 0, 0, 0 };
- static cilist io___1765 = { 0, 6, 0, 0, 0 };
- static icilist io___1769 = { 0, temq, 0, "(a9,i2,a1)", 20, 1 };
- static cilist io___1770 = { 0, 11, 0, "(a)", 0 };
- static cilist io___1772 = { 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___1764);
- e_wsle();
- s_wsle(&io___1765);
- 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___1769);
-/* 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___1770);
-/* 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___1772);
-/* 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.17/scor2prt.c b/Build/source/utils/pmx/pmx-2.6.17/scor2prt.c
deleted file mode 100644
index 13d33fb27ab..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/scor2prt.c
+++ /dev/null
@@ -1,2783 +0,0 @@
-/* scor2prt.f -- 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;
-};
-struct all_2_ {
- 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_)
-#define all_2 (*(struct all_2_ *) &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 <http://www.gnu.org/licenses/>. */
-
-
-/* 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<len here, so it's ok to get a symbol */
-
- nextsym_(line + (iline - 1 << 7), &len, &ipe, &ipenew, sym, &
- lsym, (ftnlen)128, (ftnlen)80);
- }
-
-/* Check for end of block or bar line symbol */
-
- if (i_indx("/|", sym, (ftnlen)2, (ftnlen)1) > 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_2.nvi[*iv - 1], (ftnlen)sizeof(
- integer));
- e_wsfe();
- } else {
-
-/* npages must be computed */
-
- s_wsfe(&io___210);
- i__1 = (all_2.nsyst - 1) / 12 + 1;
- do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
- e_wsfe();
- }
- } else if (iset != 7 && iset != 12) {
-
-/* write integer */
-
- s_wsfe(&io___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.17/scor2prt.f b/Build/source/utils/pmx/pmx-2.6.17/scor2prt.f
deleted file mode 100644
index c784301d046..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.17/scor2prt.f
+++ /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 <http://www.gnu.org/licenses/>.
-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 here, so it's ok to get a symbol
-c
- call nextsym(line(iline),len,ipe,ipenew,sym,lsym)
- end if
-c
-c Check for end of block or bar line symbol
-c
- if (index('/|',sym(1:1)) .gt. 0) then
- ipe = ipenew
- go to 4
- else
- wbrest = .false.
- if (alldone) go to 12
- do 5 iw = 1 , nwbrs
- wbrest = wbrest .or. sym(1:lsym).eq.wbrsym(iw)(1:lwbrs)
-5 continue
- wbrest = wbrest .or. (sym(1:lsym).eq.'r'.and.lwbrs.eq.2)
- * .or. (sym(1:lsym).eq.'rd'.and.lwbrs.eq.3)
- * .or. (sym(1:lsym).eq.'rp')
- * .or. (sym(1:lsym).eq.'r' .and. rpfirst)
-12 if (wbrest) then
- ipe = ipenew
- nmbr = nmbr+1
- go to 4
- else
-c
-c AHA! Failed prev. test, so last symbol was *not* mbr.
-c It must be saved, and its starting position is ipenew-lsym+1
-c
- if (nmbr .gt. 1) then
-c
-c Write stuff up to start of mbr
-c
- if (ip1 .gt. 1) write(40,'(a)')line(1)(1:ip1-1)
-c
-c Insert mbr symbol. Always end with a slash just in case next sym must be
-c at start of block. May think this causes undefined octaves, but
-c probably not since it's a single voice.
-c
- ndig = int(alog10(nmbr+.01))+1
- print*,'Inserting rm, iv,nmbr:',iv,nmbr
- write(40,'(a2,i'//char(48+ndig)//',a2)')'rm',nmbr,' /'
- if (alldone) go to 999
- ipc = ipenew-lsym+1
- line(1) = line(iline)(ipc:len)
- else
-c
-c Write old stuff up to end of original lonesome wbr, save the rest.
-c 4 cases: (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) ,
-c alldone.
-c In 1st 2 will have gotten some other lines, so write all up to one b4 last
-c non-comment line; then revert to normal mode on that. In 3rd case must
-c split line.
-c
- if (alldone) then
- write(40,'(a)')line(1)(1:len)
- go to 999
- else if (iline .gt. 1) then
- do 9 il = 1 , iline-1
- len = lenstr(line(il),128)
- write(40,'(a)')line(il)(1:len)
-9 continue
- line(1) = line(iline)
- else
-c
-c Since iline = 1 the wbr is not the last sym, so must split
-c
- write(40,'(a)')line(1)(1:ip1+lwbrsx-1)
- line(1) = line(1)(ip1+lwbrsx+1:len)
- end if
- end if
-c
-c Exit multibar mode
-c
- go to 7
- end if
- end if
- end if
-2 continue
- if (len .gt. 0) then
- write(40,'(a)')line(1)(1:len)
- else
- write(40,'(a)')' '
- end if
-1 continue
-999 continue
- close(10+iv)
- close(40)
- 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 .or. idur.eq.16) 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
- print*,'You entered an invalid note-length value'
- stop
- end if
- if (dotq .eq. 'd') ifnodur = ifnodur*3/2
- return
- end
- subroutine fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
- character*3 wbrsym(2)
- nwbrs = 1
- lwbrs = 2
- if (lenbar .eq. 16) then
- wbrsym(1) = 'r4'
- else if (lenbar .eq. 32) then
- wbrsym(1) = 'r2'
- else if (lenbar .eq. 64) then
- wbrsym(1) = 'r0'
- else if (lenbar .eq. 8) then
- wbrsym(1) = 'r8'
- else if (lenbar .eq. 128) then
- wbrsym(1) = 'r9'
- else
- nwbrs = 2
- lwbrs = 3
- if (lenbar .eq. 24) then
- wbrsym(1) = 'rd4'
- wbrsym(2) = 'r4d'
- else if (lenbar .eq. 48) then
- wbrsym(1) = 'rd2'
- wbrsym(2) = 'r2d'
- else if (lenbar .eq. 96) then
- wbrsym(1) = 'rd0'
- wbrsym(2) = 'r0d'
- else
- write(*,'(33H Any whole-bar rests of duration ,i3,
- * 26H/64 will not be recognized)') lenbar
- end if
- end if
- return
- end
- subroutine nextsym(line,len,ipeold,ipenew,sym,lsym)
-c
-c Know its the last symbol if on return ipenew = len!. So should never
-c be called when ipstart=len.
-c
- character*128 line
- character*80 sym
- if (ipeold .ge. len) then
- print*,'Called nextsym with ipstart>=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-PATCHES/ChangeLog b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog
index 783c0504d7a..bc303f33655 100644
--- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog
+++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/ChangeLog
@@ -1,3 +1,11 @@
+2012-05-19 Peter Breitenlohner <peb@mppmu.mpg.de>
+
+ 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 <peb@mppmu.mpg.de>
* patch-05-FreeBSD-off_t (new): Build fix for FreeBSD.
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
index 8e04162140c..de64539b668 100644
--- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes
+++ b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/TL-Changes
@@ -6,8 +6,8 @@ Remove:
aclocal.m4
configure
depcomp
+ f2c.h
install-sh
missing
+ arith.h
-(looks like the tests and other things are now in the dist, but have to
-ignore that right now, sorry. --karl)
diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-01-binary
index 16819f76212..64947854a75 100644
--- 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
@@ -2,9 +2,9 @@
Mail from Akira, 29 Mar 2012 23:50:53.
-diff -ur pmx-2.6.17.orig/libf2c/open.c pmx-2.6.17/libf2c/open.c
---- pmx-2.6.17.orig/libf2c/open.c 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/open.c 2012-03-29 17:12:53.000000000 +0200
+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"};
diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix
deleted file mode 100644
index 58de7f58ef1..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-02-bugfix
+++ /dev/null
@@ -1,19 +0,0 @@
- This should really be fixed in the Fortran source.
-
-diff -ur pmx-2.6.17.orig/scor2prt.c pmx-2.6.17/scor2prt.c
---- pmx-2.6.17.orig/scor2prt.c 2012-03-25 00:00:34.000000000 +0100
-+++ pmx-2.6.17/scor2prt.c 2012-03-29 16:59:56.000000000 +0200
-@@ -22,10 +22,10 @@
- integer nvi[24], nsyst, nvnow;
- };
- struct all_2_ {
-- integer noinow, iorig[24], noinst, insetup;
-- real replacing;
-+ integer noinow, iorig[24], noinst;
-+ logical insetup, replacing;
- integer instnum[24];
-- real botv[24];
-+ logical botv[24];
- integer nvi[24], nsyst, nvnow;
- };
-
diff --git a/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings b/Build/source/utils/pmx/pmx-2.6.18-PATCHES/patch-03-DOS-line-endings
index 5e36c101b5a..1332d7c63dd 100644
--- 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
@@ -2,9 +2,9 @@
Mail from Akira, 31 Mar 2012 21:36:26.
-diff -ur pmx-2.6.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h
---- pmx-2.6.17.orig/libf2c/fio.h 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200
+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
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
index 4017e79ac99..a536dbbf03e 100644
--- 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
@@ -3,9 +3,9 @@
Mail from Akira, 31 Mar 2012 21:36:26.
-diff -ur pmx-2.6.17.orig/libf2c/f2c.h pmx-2.6.17/libf2c/f2c.h
---- pmx-2.6.17.orig/libf2c/f2c.h 2012-03-26 12:09:53.000000000 +0200
-+++ pmx-2.6.17/libf2c/f2c.h 2012-04-01 14:50:19.000000000 +0200
+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;
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
index 8131c75d023..c26347aec6d 100644
--- 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
@@ -1,8 +1,8 @@
On FreeBSD (and maybe others) we need <sys/types.h> for off_t.
-diff -ur pmx-2.6.17.orig/libf2c/fio.h pmx-2.6.17/libf2c/fio.h
---- pmx-2.6.17.orig/libf2c/fio.h 2012-04-01 14:49:20.000000000 +0200
-+++ pmx-2.6.17/libf2c/fio.h 2012-04-23 10:06:01.000000000 +0200
+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"
diff --git a/Build/source/utils/pmx/pmx-2.6.18/arith.h b/Build/source/utils/pmx/pmx-2.6.18/arith.h
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/arith.h
+++ /dev/null
diff --git a/Build/source/utils/pmx/pmx-2.6.18/config.h.in b/Build/source/utils/pmx/pmx-2.6.18/config.h.in
deleted file mode 100644
index 5706e9a0864..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/config.h.in
+++ /dev/null
@@ -1,90 +0,0 @@
-/* config.h.in. Generated from configure.ac by autoheader. */
-
-/* Define to 1 if you have the `atexit' function. */
-#undef HAVE_ATEXIT
-
-/* Define to 1 if you have the <fenv.h> header file. */
-#undef HAVE_FENV_H
-
-/* Define to 1 if you have the `floor' function. */
-#undef HAVE_FLOOR
-
-/* Define to 1 if you have the <inttypes.h> header file. */
-#undef HAVE_INTTYPES_H
-
-/* Define to 1 if you have the `m' library (-lm). */
-#undef HAVE_LIBM
-
-/* Define to 1 if your system has a GNU libc compatible `malloc' function, and
- to 0 otherwise. */
-#undef HAVE_MALLOC
-
-/* Define to 1 if you have the <memory.h> header file. */
-#undef HAVE_MEMORY_H
-
-/* Define to 1 if you have the `memset' function. */
-#undef HAVE_MEMSET
-
-/* Define to 1 if you have the `pow' function. */
-#undef HAVE_POW
-
-/* Define to 1 if your system has a GNU libc compatible `realloc' function,
- and to 0 otherwise. */
-#undef HAVE_REALLOC
-
-/* Define to 1 if you have the `sqrt' function. */
-#undef HAVE_SQRT
-
-/* Define to 1 if you have the <stdint.h> header file. */
-#undef HAVE_STDINT_H
-
-/* Define to 1 if you have the <stdlib.h> header file. */
-#undef HAVE_STDLIB_H
-
-/* Define to 1 if you have the <strings.h> header file. */
-#undef HAVE_STRINGS_H
-
-/* Define to 1 if you have the <string.h> header file. */
-#undef HAVE_STRING_H
-
-/* Define to 1 if you have the <sys/stat.h> header file. */
-#undef HAVE_SYS_STAT_H
-
-/* Define to 1 if you have the <sys/types.h> header file. */
-#undef HAVE_SYS_TYPES_H
-
-/* Define to 1 if you have the <unistd.h> header file. */
-#undef HAVE_UNISTD_H
-
-/* Name of package */
-#undef PACKAGE
-
-/* Define to the address where bug reports for this package should be sent. */
-#undef PACKAGE_BUGREPORT
-
-/* Define to the full name of this package. */
-#undef PACKAGE_NAME
-
-/* Define to the full name and version of this package. */
-#undef PACKAGE_STRING
-
-/* Define to the one symbol short name of this package. */
-#undef PACKAGE_TARNAME
-
-/* Define to the version of this package. */
-#undef PACKAGE_VERSION
-
-/* Define to 1 if you have the ANSI C header files. */
-#undef STDC_HEADERS
-
-/* Version number of package */
-#undef VERSION
-
-/* Define to rpl_malloc if the replacement function should be used. */
-#undef malloc
-
-/* Define to rpl_realloc if the replacement function should be used. */
-#undef realloc
-
-/* Define to `unsigned int' if <sys/types.h> does not define. */
-#undef size_t
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile
deleted file mode 100644
index 528a7418bbb..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-CFLAGS = -Wall -W -pedantic -O2 -DNON_UNIX_STDIO -fPIC
-
-MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\
- getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\
- derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o
-POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
-CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
-DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
-REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
- r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
- r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
- r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
-DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
- d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
- d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
- d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
- d_sqrt.o d_tan.o d_tanh.o
-INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\
- lbitbits.o lbitshft.o
-HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
-CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
-EFL = ef1asc_.o ef1cmc_.o
-CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o
-I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\
- fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\
- open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\
- typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
-QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o
-TIME = dtime_.o etime_.o
-
-OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
- $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME)
-
-all: arith.h f2c.h signal1.h sysdep1.h libf2c.a
-
-libf2c.a: $(OFILES)
- ar r libf2c.a $?
-
-f77vers.o: f77vers.c
-
-i77vers.o: i77vers.c
-
-
-arith.h: arithchk.c
- $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\
- $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm
- ./a.out >arith.h
- rm -f a.out arithchk.o
-
-clean:
- rm -f libf2c.a *.o arith.h
-
-
-EMPTY_AUTOMAKE_TARGETS = dvi pdf ps info html tags ctags install install-data install-exec uninstall install-dvi install-html install-info install-ps install-pdf installdirs check installcheck mostlyclean distclean maintainer-clean
-.PHONY: $(EMPTY_AUTOMAKE_TARGETS)
-$(EMPTY_AUTOMAKE_TARGETS):
-
-DISTFILES =
-distdir: $(DISTFILES)
- cp Notice Makefile README *.h *.c $(distdir)
- cp f2c.h $(top_distdir)
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice b/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice
deleted file mode 100644
index 261b719bc57..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/Notice
+++ /dev/null
@@ -1,23 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
-
-Permission to use, copy, modify, and distribute this software
-and its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice appear in all
-copies and that both that the copyright notice and this
-permission notice and warranty disclaimer appear in supporting
-documentation, and that the names of AT&T, Bell Laboratories,
-Lucent or Bellcore or any of their entities not be used in
-advertising or publicity pertaining to distribution of the
-software without specific, written prior permission.
-
-AT&T, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness. In no event shall AT&T, Lucent or
-Bellcore be liable for any special, indirect or consequential
-damages or any damages whatsoever resulting from loss of use,
-data or profits, whether in an action of contract, negligence or
-other tortious action, arising out of or in connection with the
-use or performance of this software.
-****************************************************************/
-
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/README b/Build/source/utils/pmx/pmx-2.6.18/libf2c/README
deleted file mode 100644
index 73388d0bd4f..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/README
+++ /dev/null
@@ -1,329 +0,0 @@
-If your system has a double drem() function such that drem(a,b)
-is the IEEE remainder function (with double a, b), then you may
-wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
-
-On machines, such as those using a DEC Alpha processor, on which
-sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and
-sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by
-removing the first occurrence of "long " on each line containing
-"long ". On Unix systems, you can do this by issuing the commands
- mv f2c.h f2c.h0
- sed 's/long int /int /' f2c.h0 >f2c.h
-On such machines, one can enable INTEGER*8 by uncommenting the typedefs
-of longint and ulongint in f2c.h and adjusting them, so they read
- typedef long longint;
- typedef unsigned long ulongint;
-and by compiling libf2c with -DAllow_TYQUAD, as discussed below.
-
-
-Most of the routines in libf2c are support routines for Fortran
-intrinsic functions or for operations that f2c chooses not
-to do "in line". There are a few exceptions, summarized below --
-functions and subroutines that appear to your program as ordinary
-external Fortran routines.
-
-If you use the REAL valued functions listed below (ERF, ERFC,
-DTIME, and ETIME) with "f2c -R", then you need to compile the
-corresponding source files with -DREAL=float. To do this, it is
-perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile.
-
-1. CALL ABORT prints a message and causes a core dump.
-
-2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
- error functions (with x REAL and d DOUBLE PRECISION);
- DERF must be declared DOUBLE PRECISION in your program.
- Both ERF and DERF assume your C library provides the
- underlying erf() function (which not all systems do).
-
-3. ERFC(r) and DERFC(d) are the complementary error functions:
- ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
- (except that their results may be more accurate than
- explicitly evaluating the above formulae would give).
- Again, ERFC and r are REAL, and DERFC and d are DOUBLE
- PRECISION (and must be declared as such in your program),
- and ERFC and DERFC rely on your system's erfc().
-
-4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
- variable, sets s to the n-th command-line argument (or to
- all blanks if there are fewer than n command-line arguments);
- CALL GETARG(0,s) sets s to the name of the program (on systems
- that support this feature). See IARGC below.
-
-5. CALL GETENV(name, value), where name and value are of type
- CHARACTER, sets value to the environment value, $name, of
- name (or to blanks if $name has not been set).
-
-6. NARGS = IARGC() sets NARGS to the number of command-line
- arguments (an INTEGER value).
-
-7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
- EXTERNAL procedure, arranges for func to be invoked when n
- occurs (on systems where this makes sense).
-
-If your compiler complains about the signal calls in main.c, s_paus.c,
-and signal_.c, you may need to adjust signal1.h suitably. See the
-comments in signal1.h.
-
-8. ETIME(ARR) and DTIME(ARR) are REAL functions that return
- execution times. ARR is declared REAL ARR(2). The elapsed
- user and system CPU times are stored in ARR(1) and ARR(2),
- respectively. ETIME returns the total elapsed CPU time,
- i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU
- time since the previous call on DTIME.
-
-9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
- cmd to the system's command processor (on systems where
- this can be done).
-
-10. CALL FLUSH flushes all buffers.
-
-11. FTELL(i) is an INTEGER function that returns the current
- offset of Fortran unit i (or -1 if unit i is not open).
-
-12. CALL FSEEK(i, offset, whence, *errlab) attemps to move
- Fortran unit i to the specified offset: absolute offset
- if whence = 0; relative to the current offset if whence = 1;
- relative to the end of the file if whence = 2. It branches
- to label errlab if unit i is not open or if the call
- otherwise fails.
-
-The routines whose objects are makefile.u's $(I77) are for I/O.
-The following comments apply to them.
-
-If your system lacks /usr/include/local.h ,
-then you should create an appropriate local.h in
-this directory. An appropriate local.h may simply
-be empty, or it may #define VAX or #define CRAY
-(or whatever else you must do to make fp.h work right).
-Alternatively, edit fp.h to suite your machine.
-
-If your system lacks /usr/include/fcntl.h , then you
-should simply create an empty fcntl.h in this directory.
-If your compiler then complains about creat and open not
-having a prototype, compile with OPEN_DECL defined.
-On many systems, open and creat are declared in fcntl.h .
-
-If your system's sprintf does not work the way ANSI C
-specifies -- specifically, if it does not return the
-number of characters transmitted -- then insert the line
-
-#define USE_STRLEN
-
-at the end of fmt.h . This is necessary with
-at least some versions of Sun software.
-In particular, if you get a warning about an improper
-pointer/integer combination in compiling wref.c, then
-you need to compile with -DUSE_STRLEN .
-
-If your system's fopen does not like the ANSI binary
-reading and writing modes "rb" and "wb", then you should
-compile open.c with NON_ANSI_RW_MODES #defined.
-
-If you get error messages about references to cf->_ptr
-and cf->_base when compiling wrtfmt.c and wsfe.c or to
-stderr->_flag when compiling err.c, then insert the line
-
-#define NON_UNIX_STDIO
-
-at the beginning of fio.h, and recompile everything (or
-at least those modules that contain NON_UNIX_STDIO).
-
-Unformatted sequential records consist of a length of record
-contents, the record contents themselves, and the length of
-record contents again (for backspace). Prior to 17 Oct. 1991,
-the length was of type int; now it is of type long, but you
-can change it back to int by inserting
-
-#define UIOLEN_int
-
-at the beginning of fio.h. This affects only sue.c and uio.c .
-
-If you have a really ancient K&R C compiler that does not understand
-void, add -Dvoid=int to the definition of CFLAGS in the makefile.
-
-On VAX, Cray, or Research Tenth-Edition Unix systems, you may
-need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS
-to make fp.h work correctly. Alternatively, you may need to
-edit fp.h to suit your machine.
-
-If your compiler complains about the signal calls in main.c, s_paus.c,
-and signal_.c, you may need to adjust signal1.h suitably. See the
-comments in signal1.h.
-
-You may need to supply the following non-ANSI routines:
-
- fstat(int fileds, struct stat *buf) is similar
-to stat(char *name, struct stat *buf), except that
-the first argument, fileds, is the file descriptor
-returned by open rather than the name of the file.
-fstat is used in the system-dependent routine
-canseek (in the libf2c source file err.c), which
-is supposed to return 1 if it's possible to issue
-seeks on the file in question, 0 if it's not; you may
-need to suitably modify err.c . On non-UNIX systems,
-you can avoid references to fstat and stat by compiling
-with NON_UNIX_STDIO defined; in that case, you may need
-to supply access(char *Name,0), which is supposed to
-return 0 if file Name exists, nonzero otherwise.
-
- char * mktemp(char *buf) is supposed to replace the
-6 trailing X's in buf with a unique number and then
-return buf. The idea is to get a unique name for
-a temporary file.
-
-On non-UNIX systems, you may need to change a few other,
-e.g.: the form of name computed by mktemp() in endfile.c and
-open.c; the use of the open(), close(), and creat() system
-calls in endfile.c, err.c, open.c; and the modes in calls on
-fopen() and fdopen() (and perhaps the use of fdopen() itself
--- it's supposed to return a FILE* corresponding to a given
-an integer file descriptor) in err.c and open.c (component ufmt
-of struct unit is 1 for formatted I/O -- text mode on some systems
--- and 0 for unformatted I/O -- binary mode on some systems).
-Compiling with -DNON_UNIX_STDIO omits all references to creat()
-and almost all references to open() and close(), the exception
-being in the function f__isdev() (in open.c).
-
-If you wish to use translated Fortran that has funny notions
-of record length for direct unformatted I/O (i.e., that assumes
-RECL= values in OPEN statements are not bytes but rather counts
-of some other units -- e.g., 4-character words for VMS), then you
-should insert an appropriate #define for url_Adjust at the
-beginning of open.c . For VMS Fortran, for example,
-#define url_Adjust(x) x *= 4
-would suffice.
-
-By default, Fortran I/O units 5, 6, and 0 are pre-connected to
-stdin, stdout, and stderr, respectively. You can change this
-behavior by changing f_init() in err.c to suit your needs.
-Note that f2c assumes READ(*... means READ(5... and WRITE(*...
-means WRITE(6... . Moreover, an OPEN(n,... statement that does
-not specify a file name (and does not specify STATUS='SCRATCH')
-assumes FILE='fort.n' . You can change this by editing open.c
-and endfile.c suitably.
-
-Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units
-0, 1, ..., 99 are available, i.e., the highest allowed unit number
-is MXUNIT - 1.
-
-Lines protected from compilation by #ifdef Allow_TYQUAD
-are for a possible extension to 64-bit integers in which
-integer = int = 32 bits and longint = long = 64 bits.
-
-The makefile does not attempt to compile pow_qq.c, qbitbits.c,
-and qbitshft.c, which are meant for use with INTEGER*8. To use
-INTEGER*8, you must modify f2c.h to declare longint and ulongint
-appropriately; then add $(QINT) to the end of the makefile's
-dependency list for libf2c.a (if makefile is a copy of makefile.u;
-for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj
-to the library's dependency list and adjust libf2c.lbc or libf2c.sy
-accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS
-assignment. To make longint and ulongint available, it may suffice
-to add -DINTEGER_STAR_8 to the CFLAGS assignment.
-
-Following Fortran 90, s_cat.c and s_copy.c allow the target of a
-(character string) assignment to be appear on its right-hand, at
-the cost of some extra overhead for all run-time concatenations.
-If you prefer the extra efficiency that comes with the Fortran 77
-requirement that the left-hand side of a character assignment not
-be involved in the right-hand side, compile s_cat.c and s_copy.c
-with -DNO_OVERWRITE .
-
-Extensions (Feb. 1993) to NAMELIST processing:
- 1. Reading a ? instead of &name (the start of a namelist) causes
-the namelist being sought to be written to stdout (unit 6);
-to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
- 2. Reading the wrong namelist name now leads to an error message
-and an attempt to skip input until the right namelist name is found;
-to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
- 3. Namelist writes now insert newlines before each variable; to omit
-this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
- 4. (Sept. 1995) When looking for the &name that starts namelist
-input, lines whose first non-blank character is something other
-than &, $, or ? are treated as comment lines and ignored, unless
-rsne.c is compiled with -DNo_Namelist_Comments.
-
-Nonstandard extension (Feb. 1993) to open: for sequential files,
-ACCESS='APPEND' (or access='anything else starting with "A" or "a"')
-causes the file to be positioned at end-of-file, so a write will
-append to the file.
-
-Some buggy Fortran programs use unformatted direct I/O to write
-an incomplete record and later read more from that record than
-they have written. For records other than the last, the unwritten
-portion of the record reads as binary zeros. The last record is
-a special case: attempting to read more from it than was written
-gives end-of-file -- which may help one find a bug. Some other
-Fortran I/O libraries treat the last record no differently than
-others and thus give no help in finding the bug of reading more
-than was written. If you wish to have this behavior, compile
-uio.c with -DPad_UDread .
-
-If you want to be able to catch write failures (e.g., due to a
-disk being full) with an ERR= specifier, compile dfe.c, due.c,
-sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to
-slower execution and more I/O, but should make ERR= work as
-expected, provided fflush returns an error return when its
-physical write fails.
-
-Carriage controls are meant to be interpreted by the UNIX col
-program (or a similar program). Sometimes it's convenient to use
-only ' ' as the carriage control character (normal single spacing).
-If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted
-external output lines will have an initial ' ' quietly omitted,
-making use of the col program unnecessary with output that only
-has ' ' for carriage control.
-
-The Fortran 77 Standard leaves it up to the implementation whether
-formatted writes of floating-point numbers of absolute value < 1 have
-a zero before the decimal point. By default, libI77 omits such
-superfluous zeros, but you can cause them to appear by compiling
-lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 .
-
-If your (Unix) system lacks a ranlib command, you don't need it.
-Either comment out the makefile's ranlib invocation, or install
-a harmless "ranlib" command somewhere in your PATH, such as the
-one-line shell script
-
- exit 0
-
-or (on some systems)
-
- exec /usr/bin/ar lts $1 >/dev/null
-
-By default, the routines that implement complex and double complex
-division, c_div.c and z_div.c, call sig_die to print an error message
-and exit if they see a divisor of 0, as this is sometimes helpful for
-debugging. On systems with IEEE arithmetic, compiling c_div.c and
-z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both
-the real and imaginary parts of the result to +INFINITY if the
-numerator is nonzero, or to NaN if it vanishes.
-
-Nowadays most Unix and Linux systems have function
- int ftruncate(int fildes, off_t len);
-defined in system header file unistd.h that adjusts the length of file
-descriptor fildes to length len. Unless endfile.c is compiled with
--DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if
-necessary to shorten files. If your system lacks ftruncate(), compile
-endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more
-portable scheme of shortening a file by copying to a temporary file
-and back again.
-
-The initializations for "f2c -trapuv" are done by _uninit_f2c(),
-whose source is uninit.c, introduced June 2001. On IEEE-arithmetic
-systems, _uninit_f2c should initialize floating-point variables to
-signaling NaNs and, at its first invocation, should enable the
-invalid operation exception. Alas, the rules for distinguishing
-signaling from quiet NaNs were not specified in the IEEE P754 standard,
-nor were the precise means of enabling and disabling IEEE-arithmetic
-exceptions, and these details are thus system dependent. There are
-#ifdef's in uninit.c that specify them for some popular systems. If
-yours is not one of these systems, it may take some detective work to
-discover the appropriate details for your system. Sometimes it helps
-to look in the standard include directories for header files with
-relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and
-it may be simplest to run experiments to see what distinguishes a
-signaling from a quiet NaN. (If x is initialized to a signaling
-NaN and the invalid operation exception is masked off, as it should
-be by default on IEEE-arithmetic systems, then computing, say,
-y = x + 1 will yield a quiet NaN.)
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c
deleted file mode 100644
index 94c93e2f2a4..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/arithchk.c
+++ /dev/null
@@ -1,225 +0,0 @@
-/****************************************************************
-Copyright (C) 1997, 1998, 2000 Lucent Technologies
-All Rights Reserved
-
-Permission to use, copy, modify, and distribute this software and
-its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice appear in all
-copies and that both that the copyright notice and this
-permission notice and warranty disclaimer appear in supporting
-documentation, and that the name of Lucent or any of its entities
-not be used in advertising or publicity pertaining to
-distribution of the software without specific, written prior
-permission.
-
-LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
-INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
-IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
-SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
-IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
-ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
-THIS SOFTWARE.
-****************************************************************/
-
-/* Try to deduce arith.h from arithmetic properties. */
-
-#include <stdio.h>
-#include <math.h>
-#include <errno.h>
-
-#ifdef NO_FPINIT
-#define fpinit_ASL()
-#else
-#ifndef KR_headers
-extern
-#ifdef __cplusplus
- "C"
-#endif
- void fpinit_ASL(void);
-#endif /*KR_headers*/
-#endif /*NO_FPINIT*/
-
- static int dalign;
- typedef struct
-Akind {
- char *name;
- int kind;
- } Akind;
-
- static Akind
-IEEE_8087 = { "IEEE_8087", 1 },
-IEEE_MC68k = { "IEEE_MC68k", 2 },
-IBM = { "IBM", 3 },
-VAX = { "VAX", 4 },
-CRAY = { "CRAY", 5};
-
- static double t_nan;
-
- static Akind *
-Lcheck()
-{
- union {
- double d;
- long L[2];
- } u;
- struct {
- double d;
- long L;
- } x[2];
-
- if (sizeof(x) > 2*(sizeof(double) + sizeof(long)))
- dalign = 1;
- u.L[0] = u.L[1] = 0;
- u.d = 1e13;
- if (u.L[0] == 1117925532 && u.L[1] == -448790528)
- return &IEEE_MC68k;
- if (u.L[1] == 1117925532 && u.L[0] == -448790528)
- return &IEEE_8087;
- if (u.L[0] == -2065213935 && u.L[1] == 10752)
- return &VAX;
- if (u.L[0] == 1267827943 && u.L[1] == 704643072)
- return &IBM;
- return 0;
- }
-
- static Akind *
-icheck()
-{
- union {
- double d;
- int L[2];
- } u;
- struct {
- double d;
- int L;
- } x[2];
-
- if (sizeof(x) > 2*(sizeof(double) + sizeof(int)))
- dalign = 1;
- u.L[0] = u.L[1] = 0;
- u.d = 1e13;
- if (u.L[0] == 1117925532 && u.L[1] == -448790528)
- return &IEEE_MC68k;
- if (u.L[1] == 1117925532 && u.L[0] == -448790528)
- return &IEEE_8087;
- if (u.L[0] == -2065213935 && u.L[1] == 10752)
- return &VAX;
- if (u.L[0] == 1267827943 && u.L[1] == 704643072)
- return &IBM;
- return 0;
- }
-
-char *emptyfmt = ""; /* avoid possible warning message with printf("") */
-
- static Akind *
-ccheck()
-{
- union {
- double d;
- long L;
- } u;
- long Cray1;
-
- /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */
- Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762;
- if (printf(emptyfmt, Cray1) >= 0)
- Cray1 = 1000000*Cray1 + 693716;
- if (printf(emptyfmt, Cray1) >= 0)
- Cray1 = 1000000*Cray1 + 115456;
- u.d = 1e13;
- if (u.L == Cray1)
- return &CRAY;
- return 0;
- }
-
- static int
-fzcheck()
-{
- double a, b;
- int i;
-
- a = 1.;
- b = .1;
- for(i = 155;; b *= b, i >>= 1) {
- if (i & 1) {
- a *= b;
- if (i == 1)
- break;
- }
- }
- b = a * a;
- return b == 0.;
- }
-
- static int
-need_nancheck()
-{
- double t;
-
- errno = 0;
- t = log(t_nan);
- if (errno == 0)
- return 1;
- errno = 0;
- t = sqrt(t_nan);
- return errno == 0;
- }
-
-main()
-{
- FILE *f;
- Akind *a = 0;
- int Ldef = 0;
-
- fpinit_ASL();
-#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */
- f = fopen("arith.h", "w");
- if (!f) {
- printf("Cannot open arith.h\n");
- return 1;
- }
-#else
- f = stdout;
-#endif
-
- if (sizeof(double) == 2*sizeof(long))
- a = Lcheck();
- else if (sizeof(double) == 2*sizeof(int)) {
- Ldef = 1;
- a = icheck();
- }
- else if (sizeof(double) == sizeof(long))
- a = ccheck();
- if (a) {
- fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n",
- a->name, a->kind);
- if (Ldef)
- fprintf(f, "#define Long int\n#define Intcast (int)(long)\n");
- if (dalign)
- fprintf(f, "#define Double_Align\n");
- if (sizeof(char*) == 8)
- fprintf(f, "#define X64_bit_pointers\n");
-#ifndef NO_LONG_LONG
- if (sizeof(long long) < 8)
-#endif
- fprintf(f, "#define NO_LONG_LONG\n");
- if (a->kind <= 2) {
- if (fzcheck())
- fprintf(f, "#define Sudden_Underflow\n");
- t_nan = -a->kind;
- if (need_nancheck())
- fprintf(f, "#define NANCHECK\n");
- }
- return 0;
- }
- fprintf(f, "/* Unknown arithmetic */\n");
- return 1;
- }
-
-#ifdef __sun
-#ifdef __i386
-/* kludge for Intel Solaris */
-void fpsetprec(int x) { }
-#endif
-#endif
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h
index b94ee7c8e12..a91de9bf804 100644
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h
+++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/f2c.h
@@ -13,6 +13,9 @@ 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;
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
index 3d168bfcd1a..b16957a8fae 100644
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h
+++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/fio.h
@@ -1,7 +1,12 @@
#ifndef SYSDEP_H_INCLUDED
#include "sysdep1.h"
#endif
+#include <sys/types.h> /* for off_t */
#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/libf2c/open.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c
index 6e3def121df..49f739a3d7d 100644
--- a/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c
+++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/open.c
@@ -30,6 +30,9 @@ extern integer f_clos(cllist*);
#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/pmx2617.f b/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f
deleted file mode 100644
index 09b5ec6e0dc..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/pmx2617.f
+++ /dev/null
@@ -1,23597 +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 <http://www.gnu.org/licenses/>.
-c
-c
- character*9 date
- character*5 version,versionc
- common /comver/ versionc
-c
-c To compile with gfortran:
-c 1. Merge all files using copy *.for epmx[nnnn].for
-c 2. Search and replace all character*65536 with character*131072
-c 3. Comment/uncomment getarg lines
-c 4. gfortran -O pmx[nnnn].for -o pmxab.exe
-c
-c To do
-c Correct Rainer's email address in manual
-c Linesplit (\\) in h
-c Tt at start of a movement.
-c Toggle midi on or off; allow midi only.
-c Page number printed on 1st page even if 1 system.
-c Still need inserted space for chordal accidentals
-c Voicewise transposition.
-c better segno
-c coda
-c duevolte
-c Fix xtup bracket direction in 2-line staves?? (maybe leave as is)
-c Sticky ornaments with shifts.
-c Deal with Werner's vertical spacing thing associated with title.
-c Multiple ties in midi
-c Werner's missing c in MIDI due to start/stop ties on same note.
-c Beams with single 64ths
-c 128ths and/or dotted 64ths
-c Close out MIDI with integral # of beats?
-c Increase ast dimensions or redo logic.
-c Does slur direction get set for user-defined single-note stem dir'ns?
-c Transpose by sections.
-c Optimization loop over sections only
-c Command-line option to read nbarss in. Write out nbarss when optimizing.
-c (or just read from .plg?)
-c Beams over bar lines.
-c 2-digit figures
-c A real coule (slanted line between notes in a chord)
-c Dotted slurs for grace notes.
-c Undotted chord notes with dotted main note.
-c Forced line break without line number
-c Fix dot moving when 2nds in chord get flipped
-c To do: increase length on notexq in dodyn
-c 2.617
-c In g1etnote, change if-check for note to use index(...) instead
-c of ichar(charq) since it was messing up gfortran optimizer
-c After pmxa, search for and remove penultimate line <blank><blank>/
-c because it was screwing up linux-compiled versions
-c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...)
-c 2.616 (111110)
-c Allow hairpins to span multiple notes groups (gulps).
-c 2.615+ (110810)
-c Fix midi when some instruments are transposed, by subtracting
-c iTransAmt(instno(iv)) from pitch values sent to via addmidi in
-c make2bar.for (for main notes) and docrd (for chord notes)
-c 2.615 (110725)
-c Fig bug with size-setting (in topfile) when instrument has >1 staves
-c 2.615 (110724)
-c Make AS[0|-|s|t]... really set sizes
-c 2.614
-c Mod notex.for to fix Terry's bug with raised dotted rests (caused
-c by double-hboxing).
-c 2.613
-c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno.
-c 2.612
-c Enhance AS to allow s or t for smallsize or tinysize
-c 2.611
-c Error trap for "D" before any notes in a block.
-c 2.610
-c Instrument-wise key changes and transposition (incomplete)
-c 2.603
-c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors
-c following reading in an include file.
-c 101121 Added some error messages in g1etset.for setup data
-c 2.602
-c Correct slur indexing in linebreakslurs.
-c Account for comment lines in line count for error messages
-c 2.601
-c Bug fix: allow 24 slurs with graces
-c 2.60 Changes made make it really big
-c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o
-c major reprogramming, and 16 may also be a problem (icmm)
-c nm=24 (voices) done
-c 24 slurs done
-c 24 simultaneous beams (Replace index 24 by 0, so get 0-23)
-c bufq*131072 (gfortran only)
-c getarg syntax (gfortran only)
-c 2.523+
-c Fix voice numbering for normal dynamics and text dynamics
-c 2.523
-c Version of bigpmx first posted to Hiroaki's web site.
-c 2.522
-c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it.
-c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices.
-c 5/13/10 Fix log2 function
-c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length.
-c 2.521+
-c 091025 Enable dotting 2nd part of linebreak slur or tie.
-c To adjust barno height due to linebreak slur, use \bnrs instead of
-c explicitly redefining \raisebarno (pmxb)
-c 2.521
-c Bugfix
-c 2.520
-c 090519 Enable ligfonts (special figured bass characters)
-c 2.519
-c Fix another bug which kept \sk from being output so misaligned some notes.
-c 2.518
-c Fix bugs: referencing fig data, char declaration for member of
-c common/comfig/
-c 2.517
-c Allow figures in voice 1 + any one other.
-c 2.516
-c Allow figures in voice #2
-c 2.515+ to do: Change manual and activate rule against clef change in voice #2.
-c 2.515
-c 071222 Changes in getnote to allow auto forced beams to start anywhere.
-c 071206 In make2bar, shift fermataup7 to left over centered pause.
-c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line
-c staff (it was screwing up vertical justification).
-c n34 for tweaks to midi durations of quarter note septuplets.
-c To do: In ref250.tex, the tables where 's,t,)' is explained, the line
-c [+,- i] ... Vertical adjustment of the start of second segment
-c should it be replaced by
-c [s +,- i] ... Vertical adjustment of the start of second segment
-c 2.514
-c Changes in make2bar to get horizontal spacing right when normal grace
-c follows after grace
-c Changes in dograce to get octaves right for any material entered inside
-c \gaft, which shields transpose register changes from the outside world.
-c 2.513
-c In make1bar, near end, for forced beams starting with a rest, copy hgt and
-c slope tweaks to ALL notes after first, not just the second one, so if
-c there's more than one rest at start the tweaks are still observed.
-c In beamid and beamend, add stand-alone triply-flagged notes for xtups.
-c 2.512
-c Near end of pmxb, fix error trap to allow redundant 'RD'
-c Enable multiplicity down-up '][' within xtup.
-c 2.511
-c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by
-c adjusteskz as in bar 7 of barsant.
-c 2.510a
-c Test: remove restriction on tempo changes in MIDI macros
-c Send to CM for beta testing.
-c 2.509+
-c To do: Correct manual on AS. "-" is for smaller staves.
-c 2.510
-c Forgot to declare litq, voltxtq as character in subroutine getgrace
-c 2.509
-c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp)
-c 2.508
-c Allow graces in xtups. New subroutine getgrace.
-c 2.507
-c To do: Raise/lower figures.
-c To do: Add 24, 29 to list of musicsizes in manual
-c New sub adjusteskz to account for ask's when computing lengths of
-c brackets for unbeamed xtups, slopes and horizontal posn's of number
-c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags
-c Add look-left option for keyboard rests, "L" in rest command, set iornq(30)
-c 2.506
-c Fix bug with AK, when simultaneous rests have same duration, use defaults.
-c 2.505
-c Keyboard rests AK
-c 2.504
-c Space after normal grace: option X[n]
-c Fixed og when nv .ne. noinst, by using sepsymq instead of '&'
-c (To do) length of xtup bracket when there is added non-collision space.
-c Trap musicsize if .ne. 16,20,24,29.
-c 2.503
-c Enable arpeggio left shift with ?-x
-c To do: In manual, arpeggio over 2 staves.
-c Allow musicsize of 24 and 29. Had to define meter font size explicitly,
-c also change font size for text dynamics, but not much else so far.
-c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn
-c was called, causing error in printing replacement number.
-c 2.502
-c Incorporate Dirk Laurie's patch to use { , } , for ties.
-c Figure height adjustment: append +[n]
-c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?)
-c 2.501
-c Readjust horizontal offset back to .8 in LineBreakTies
-c Fix zero-subscript (iudorn) in putorn
-c 2.50
-c Increase number of text-dynamics (dimension of txtdynq) per block
-c from 12 to 41.
-c Slur option n to override altered default curvature.
-c Allow default ps slur curvature tweaks with Ap+/-c
-c 2.416
-c Increase length of textdynq from 24 to 128
-c (Todo) Add comment in manual about blank lines at end.
-c Configuration file: Define subroutine getpmxmod, check path in environment
-c variable pmxmoddir, check existence, read lines into bufq after setup.
-c Increase dimension on idynn in dodyn from 4 to 10 for max number
-c of marks in a bar
-c Increase allowable # of lines from 2000 to 4000.
-c (To do) Replace definition of \liftpausc per Olivier.
-c (To do) Fix extraneous error message if RD is placed at very end.
-c 2.415
-c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt
-c instead of redefining \xnum. Change font used to \smallfont (as for
-c normal xtups,
-c Allow slur to start on rest.
-c 2.414
-c Correct bug in crdacc when adding accidental to boundary causes number of
-c segments to decrease
-c Special rule for 3-accidental chords: If no 2nds, place them in order
-c top, bottom, middle.
-c 2.413
-c Correct bugs in chordal accidentals, related to left-shifted noteheads
-c (a) Special problems with downstem when main note needs shifting
-c (b) Assign 0 rank to boundary segs due to left-shifted noteheads
-c 2.412
-c Change default horiz shift of start of seg 2 of linebreak slurs:
-c -.7 for slurs, -1.2 for ties,
-c Use height of start of seg 1 slur itself for end of 1 and start of 2.
-c 2.411
-c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2.
-c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end
-c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2.
-c With "Apl", curvature adjustments on starting slur command apply to seg 1,
-c those on ending command to seg 2.
-c 2.410
-c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine
-c \xnum, \unbkt, \ovbkt.
-c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is
-c flag, mult(5-9) is tweak value+16
-c 2.409
-c Bugfix in docrd for MIDI: Use original pitch in case main/chord were
-c switched due to 2nds.
-c Remove "o" from error message for "A" command.
-c New syntax: optional instrument number separator ":" in movement
-c break command to precede a 2-digit instrument.
-c Conditional output formats for \setname at movement break to allow
-c instrument numbers >9.
-c Bugfix in coding to raise barno due to slur over line break (pmxb)
-c Move date/version data statement in pmxab to a better place.
-c 2.408
-c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar).
-c Bug fix in \liftPAusep in notex.for and in pmx.tex
-c Character variables for version and date
-c For up-stem single graces slurred to down-stem, shift slur start left by
-c 0.8 so slur doesn't get too short.
-c Initialize and slide mult, same as other full-program variables in /all/.
-c 2.407
-c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n,
-c 2.406
-c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing
-c equalization).
-c Put dimensions of double sharps and flats in crdacc (for chords).
-c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&'
-c Use only first 4 bits of mult for multiplicity+8, so rest can be used
-c for other stuff.
-c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict.
-c 2.405: Not published but saved for safety.
-c Option Aph to write \special{header=psslurs.pro} top of each page, so
-c dviselec will work OK.
-c 2.404
-c Allow slur to end on rest, but not start on a rest. Efaults height
-c of ending is default height of start (before any automatic or user-
-c defined djustments). User may adjust height as normal from default.
-c 2.403
-c Bugfix: turn off repeated beaming patterns.at end of non-last voice.
-c 2.402
-c Automatic repeated forced beams. Start with "[:" End with next explicit
-c forced beam or end of input block.
-c Increase # of forced beams per line of music per input block from 20 to 40
-c 2.401
-c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies.
-c Makes 1st part normal shape, and starts 2nd part a little further left.
-c Enable arpeggios in xtuplets. Had to make time itar(narp) a real.
-c 2.40
-c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap.
-c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse
-c sign for down-slurs.
-c 2.359
-c Add error exit subroutine stop1 to make exit status g77-compatible..
-c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote
-c Fermata on vertically shifted rest: special trap in putorn() to set height.
-c Correct multiple grace note spacing for small staves (in dograce,
-c define wheadpt1 depending on staff size)
-c 2.358
-c Allow curvature corrections at start of postscript slur, in dopsslur()
-c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust
-c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h]
-c Make t[ID] act like s[ID]t, most mods in spsslur().
-c Add spsslur() to read in data for ps slurs, call from getnote.
-c In beamstrt, save args for SetupB in common comipb to save them for
-c 2nd call when xtup starts with rest
-c Add spacing for ornament ")" as if it were accidental, in make2bar().
-c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur()
-c Horiz. shift start of ps grace slur, 2 places in dograce().
-c Horiz shift end of grace slur in endslur()
-c Make st slurs into postscript ties. Separate subroutine dopsslur(),
-c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.)
-c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn.
-c 2.357a
-c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote
-c 2.357
-c Increase dimension for # of lit TeX strings from 52 to 83.
-c Allow blank rest in middle of xtuplet. Only mods in g*etnote().
-c 2.356
-c Increased some dimensions from 30 to 40 to allow up to 40 pages.
-c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt().
-c Fix parsing of "f,h,H,HH" in sslur.
-c Fix bug with cdot, note-level for slur termination (in getnote)
-c 2.355
-c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)],
-c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues
-c Make midi recognize ps ties in doslur.
-c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote
-c to get octave right.
-c 2.354
-c With postscript slurs, make t-slurs real ties by inserting replacement
-c macros \tieforisu, etc, defined in pmx.tex
-c Check for open cresc or decresc at end of input block, using list[de]cresc
-c Hairpin syntax conditional on postscript slurs. Backup to fill in start
-c level, using new backfill(...). Separate height tweaks for
-c start and finish.
-c 2.353
-c K-0+n to transpose by half step (rather than just change key)
-c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of
-c \mbrest's
-c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end
-c of input block before movement break, and at start of block after
-c movement break, using \newmovement rather than \setzalaligne, since
-c former already redefines \stoppiece. In second case, set rptfg2='z'.
-c Make clefq(nm) common between pmxb and getnote; change references in
-c getnote at 'M' to array elements, setting all new clefs as you go.
-c 2.352
-c Remove \parskip redefinition from pmx.tex; write it into TeX file when
-c "Ae" is invoked.
-c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine
-c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH',
-c translate them thru mapping to (1,4,5,6) as \midslur params, then let
-c \psforts translate them back to ps slur macors.
-c 2.351
-c Number slurs from 0 up instead of 11 down, anticipating postscript slurs.
-c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size.
-c Increase length of basenameq to 44 characters everywhere.
-c Increase dimension of mcpitch (midi-chord-pitch) to 20.
-c Set default systems per page to 1 if nv>7
-c In pmxb, move place where isystpg is reset to 0, so that \eject gets
-c written when there is just one system per page.
-c 2.35
-c Cautionary accidentals with 'c' anywhere in note symbol.
-c NEW pmx.tex with \resetsize to set size to normal or small depending on
-c current \internote. Used with new coding in dograce() to get right
-c new size in case user has \setsize'ed some lines to \smallvalue. For
-c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font.
-c Affects pmx.tex.
-c Continuation figure with fractional length. May now mix with other figures.
-c If another figure follow Cont-fig, separate with colon.
-c 2.342
-c Bugfix in getnote to recognize relative octave shift in grace at start of
-c input block.
-c In make2bar, initialize islhgt=0 earlier than before (possible solution
-c to Suse g77 compile problem that I could not reproduce)..
-c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d
-c 2.341
-c Syntax check: Forced page break page number must be > than previous.
-c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb.
-c 2.34
-c New pmx.tex with redefined liftpausc
-c Bug fix with dotted, non-beamed xtups.
-c 2.332
-c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads.
-c Allow arbitrary pos. input to W in g1etnote and getnote.
-c 2.331
-c Bug-fix in dodyn(..): typo on length of arg of txtdyn
-c 2.33
-c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata()
-c 2.321
-c Rescale accidental shifts. Still use 7 bits but now map (0,127)
-c onto (-1.,5.35)
-c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups
-c 2.32 (Noticed after posting)
-c Prohibit "/" as figure.
-c 2.32 (Posted)
-c Tidied up accidentals in chords, do spacing.
-c Still to do:
-c check for "(" on chord notes in spacing algo
-c small accids
-c double accids
-c autoshift slurs
-c 2.310
-c Extra call to precrd ahead of spacing chk, and single-note crd/acc
-c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time.
-c 2.309
-c Alternate algo for accid shifts in chords.
-c 2.308
-c Auto horiz. notehead shifting added to precrd.
-c 2.307
-c Auto shifting of multiple accidentals in chords.
-c "Ao" in main chord note to keep accidentals in order. Set nacc(28).
-c If there are any manual main or chord note shifts, then
-c If any manual shift is preceded by "A" then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts,
-c End if
-c End if
-c 2.306
-c Initialize legacy note level to middle C in case user forgets to set
-c octave.
-c Shift xtup note?
-c Shift in elemskips rather than noteheads?
-c 2.305
-c Stop pmxb from multiple endvolta's at start of new page.
-c 2.304
-c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on
-c for multiple notes in the voice, "S:" last shortened note.
-c 2.303
-c vshrink stuff all OK? Description is in pmxb.
-c 2.302
-c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff
-c hits 20. This still needs work.
-c Add " /" to last line if last char is not % or /.
-c 2.301
-c Check in beamn1 for single note before multiplicity down-up.
-c allow '.PMX' as well as '.pmx'
-c 2.299
-c Correct typo in pmxb involving PMXbarnotrue.
-c Replacement printed number for xtup: Unsigned integer after 'n' after 'x'
-c Minor upgrade parsing xtuplet options 'x...'
-c Correct dimension of nxtinbm in make2bar.
-c 2.298
-c Account for doubled xtup notes in subroutine getx (user-defined spaces),
-c by adding ndoub as an argument..
-c 2.297
-c Created and solved compiler problem. Put drawbm(NM) in its own common.
-c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar
-c when \centerbar is used.
-c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX
-c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes.
-c 2.296
-c Correct printed numbers for forced beams with multiple xtups. For each beam
-c make list in setupb by voice of eloff (h-offset) and mtupv (printed #)
-c Increase lengths of jobname and infileq by 20 characters
-c Enable whole notes and breves as 1st or last note of xtup in beamn1 and
-c beamend, and wholes in beamid.
-c 2.295
-c Midi balance Ib[n1]:[n2]:...[nn]
-c Single-slope beam groups [...]-[...]
-c Trap "i" unless after accidental (main notes, xtups, chord notes)
-c 2.294
-c Unequal xtups with "D" to double a note in an xtup.
-c As above, "F" will (a) increase multiplicity by 1 for marked note and next
-c one and (b) add a dot to the first one.
-c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on
-c when "." is encountered, then correcting beam start time.(end of getnote)
-c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]...
-c 2.293
-c Check for single notes spanning bar lines.
-c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup
-c must be set in make2bar since beamstrt is not called, fixing problem with
-c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix
-c problem when >2 staves.
-c Add nodur to args of dodyn, so can check if stemless and avoid height tweak
-c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak
-c 2.292a
-c Undo syntax check for Type 2 or 3 TeX string starting in column 1.
-c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?!
-c 2.292
-c Allow comments in xtuplets
-c Enable multiple octave jumps in grace notes.
-c Allow dynamics in xtuplets.
-c Fix bug in getdyn searching for end of text string (correct length of lineq
-c to 128)
-c Fix bug in dodyn, must ignore horiz. interaction tweak for
-c user-text (idno = 0)
-c Syntax check for Type 2 or 3 TeX string starting in column 1
-c (NOTE: later undone!)
-c Syntax check for page number > npages at forced line break.
-c 2.291
-c Fix error in AS command (accid spacing for small systems), making only
-c one spec per staff, nv total.
-c Stop using MIDI channel 10
-c 2.29
-c Fix error in console output format for # of bytes used in MIDI file.
-c Fix bug in dograce so no space is added between grace and main note when
-c there is a MIDI-only accidental.
-c Fix bug so oes?+4 works. It was too ugly to explain.
-c ...Different ways of storing accidental specs on input and output.
-c No longer zap \writezbarno in special situations.
-c Fix bug in dyntxt level on rest
-c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc.
-c Activate with Ae. (Maybe later could input alternate values for
-c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1
-c in the page, and \endeq on 1st note of next-to-last line in page.
-c 2.28
-c Flip direction of forced beam "[f..."
-c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30)
-c Fix bug in sliding ip's for txtdyn's
-c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99)
-c 2.27
-c Comment out lines in dodyn checking number of dynamic marks found. Voice
-c order may not be monotonic if two lines on a staff.
-c Literal dynamic: D"[text]"
-c 2.26
-c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn,
-c increasing dimension of idynn to 4 to allow 4 symbols on same note.
-c Increase voltxtq length from 10 to 20.
-c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough
-c accounting for ast's is done by defining effective headwidth
-c whead1 in makebar2 to be 0.8*whead.
-c 2.25
-c Fix logic bug with sepsym's when # of instruments changes.
-c Slight increases in default offsets for hairpin starts after "p"
-c 2.24
-c Hairpins D< or D> as toggle.
-c Many automatic position tweaks for letter-group dynamics and hairpins.
-c 2.23
-c Continued rhythmic shortcuts: space followed by "." or ","
-c 2.22
-c In call to doslur, change tno(...) to tnote(...). This was only
-c used when checking to slurs per stem directions, and should have been
-c the note duration all along.
-c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat.
-c Use "i" anywhere in note symbol.
-c 2.21
-c Increase from 20 to 30 dimensions for movement breaks and midi sections.
-c Fix out-of-order declarations per mutex comments
-c Add "Bad error" and "Kluging" messages to log file.
-c 2.197
-c add /comips/ to save tie-check midi variables
-c For spacing of clef changes at start of input block, changed integer time
-c lastnodur to prevtn, so it works with xtups. Possible incompatibility!
-c 2.196
-c Fix Ickbug with time check in ncmid()
-c Interchange \fermataup7 and \pausec to get proper alignment
-c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX.
-c Add defn's of \hsp, \hspp to pmx.tex
-c Fix pre-slurs on xtup chord notes.
-c Fixed raised PAuse, define \liftPAuse
-c Replace \zbreve\sk with \breve.
-c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what
-c about "o" and 1 as shorthand for 16???? Search for "Kluge"
-c Added "vo" (voice) as MIDI instrument 55
-c Allow 3-digit page numbers (search for "toppageno")
-c Fix bug caused by prior fix (cancelling accid after bar line was ignored).
-c Fix double accids in chords
-c 2.194
-c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if
-c block.
-c Add meter to MIDI file with every pause
-c Purify FORTRAN?
-c 2.193
-c Increased # of in-line TeX strings from 36 to 52.
-c Fix entry of # of bytes in header of tempo/meter/key track to allow >255.
-c 2.191
-c Event track: Tempos, meters, keys all together. Data in comevent
-c 2.15
-c Pretty good midi capability. Still no attention to slurs on chord notes.
-c 2.11
-c 11 Dec 99 c rm1
-c 11 Dec 99 "oes?", "oe?"
-c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes
-c 11 Dec 99 Error message for shifted, repeated ornaments.
-c 2.10 (Version 2.1)
-c Fix bug with lowdot and xtuplets
-c 2.09
-c Fix bug with multiple ornament heights over beams, when one is . or _
-c Error message from pmxa if rest on last note of xtup.
-c Enable 12 slurs.
-c Reinstate multiple rests at start of xtup.
-c 2.07
-c Combine consecutive type-1 TeX strings.
-c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's.
-c Fixed breve chord notes in docrd
-c Check irest(28) as well as vxtup when setting nodur for chord notes, since
-c vxtup isn't set until 1st *main* note in xtup
-c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing.
-c 2.06+
-c Make deterministic the beam slope calculation when there are an even # of
-c slopes in list and middle two are equal magnitude but opposite sign.
-c pmxa Trap for "o:" before 1st note in block
-c Partial bug fix for 64th notes in xtuplets.
-c Make ixrest a vector, since with new time scheme may not finish xtup in
-c same notes block.
-c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb)
-c 2.06
-c Account for changes in nv when computing \interstaff. Add a counter
-c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever
-c setting isysflb(iflb). Note nv can only change at a forced line break.
-c Note also, iflb starts at 0!
-c 2.05
-c Automatic start of new notes group with part 2 of staff-jump beam
-c In make1bar, set irest bit 29 of lowest-voice note at same time,
-c use as flag when making notes groups.
-c For now, remove dummy blank line at end...it zaps terminal repeats.
-c 2.02
-c Fixed slur-counting bug for multiple, slurred, aftergraces.
-c 2.01
-c Increase to ask(1400)
-c Increase max forced page breaks to 18
-c Define pausc for centered pause
-c 2.0a
-c Insert dummy blank line at very end to handle input files w/o terminal CR-LF
-c pmx03r
-c Option m[n] in S symbol to change musicsize (for parts)
-c Double dotted rests now work.
-c Write file name to log file
-c Check existence of input file
-c Allow 24-char jobname, may end with ".pmx"
-c Comment out time stuff
-c Replace 3-argument getarg with 2-argument + iargc
-c Fix bug with negative noinst due to nint<=int replacement
-c move lovation of iv in isdat1 to allow iv>7.
-c Set nm=12
-c pmx03q
-c replace int(x+.001) with nint(x)
-c Write TeX file name to screen and to pml.
-c Replace char(...) with chax(...) to sovle msdev bug.
-c Bug fix: macro terminations when M is on a line by itself.
-c Bug fix: don't accumulate space for XS in pmxa.
-c Streamline Macros: use pointers to bufq instead of scratch files
-c pmx03p
-c Store input file in single character array bufq.
-c lbuf(i)*2 is length of line i
-c ipbuf is position just before next line to be read.
-c pmx03
-c Optimize read/writes
-c pmx02
-c Fix line count (for errors) when there are saved macros
-c pmx01
-c In optimize mode, open/close macros (Watch out for residual zz files!)
-c Command line input
-c Option Ao to optimize, otherwise normal processing
-c
-ccccccc
- parameter (nks=125,nm=24,mv=24576,maxblks=4000)
- character*128 lnholdq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /comevent/ miditime,lasttime
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- common /commus/ musize,whead20
- integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks)
- real*4 poe0(nks),poe(nks)
- logical isfirst,optimize
- logical*4 fexist
- character*44 jobname
- character*47 infileq
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * idum,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- logical rest,firstline,newmeter
- common /comdiag/ n69(0:nm),n34(0:nm)
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- common /truelinecount/ linewcom(20000)
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
-ccccccccccccccccccccccccc
-c
- data date /'28 Jan 12'/
- data version /'2617'/
-c
-ccccccccccccccccccccccccc
- data maxit,ncalls /200,0/
- data isfirst /.true./
-c itstart = mytime()
- versionc = version
-c
-c Initialize midi parameters
-c
- gottempo = .false.
- ismidi = .false.
- debugmidi = .false.
- relacc = .false.
- mmacrec = .false.
- nmidsec = 1
- mgap = 10
- miditime = 0
- lasttime = 0
- nmidcrd = 0
- nusebl = 0
- notmain = .false.
- do 3 ivx = 1 , nm
- twoline(ivx) = .false.
- midinst(ivx) = 6
- midivel(ivx) = 127
- midibal(ivx) = 64
- miditran(ivx) = 0
-3 continue
- do 12 icm = 0 , nm
- imidi(icm) = 0
- restpend(icm) = .false.
- trest(icm) = 0.
- levson(icm) = 0
- levsoff(icm) = 0
- slmon(icm) = .false.
- naccbl(icm) = 0
- n69(icm) = 0
- n34(icm) = 0
- msecstrt(icm,1) = 1
-12 continue
-c
-c End of midi parameter initialization
-c
- musize = 0
- optimize = .false.
- numargs = iargc()
- if (numargs .eq. 0) then
- print*,'You could have entered a jobname on the command line,'
- print*,' but you may enter one now:'
- read(*,'(a)')jobname
- numargs = 1
- else
-c call getarg(1,jobname,idum) ! May need to replace this w/ next line
- call getarg(1,jobname)
- end if
-10 ljob = lenstr(jobname,44)
- if (ljob .gt. 44) then
- print*,'Jobname is too long. Try again.'
- call stop1()
- else if (ljob .eq. 0) then
- print*,'No was jobname entered. Try again.'
- call stop1()
- else if (numargs .eq. 2) then
- if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then
- optimize = .true.
-c call getarg(2,jobname,idum) ! May need to replace this w/ next line
- call getarg(2,jobname)
- numargs = 1
- go to 10
- else
- print*,'Illegal option on command line'
- call stop1()
- end if
- end if
-c
-c Strip ".pmx" if necessary
-c
- ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
- if (ndxpmx .gt. 0) then
- jobname = jobname(1:ndxpmx-1)
- ljob = ljob-4
- end if
-c
-c Check for existence of input file
-c
- infileq = jobname(1:ljob)//'.pmx'
- inquire(file=infileq,EXIST=fexist)
- if (.not.fexist) then
- inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist)
- if (.not.fexist) then
- print*,'Cannot find file '//infileq
- call stop1()
- else
- infileq = jobname(1:ljob)//'.PMX'
- end if
- end if
-c
-c Open a log file
-c
- open(15,file=jobname(1:ljob)//'.pml')
- call printl('This is PMX, Version '//version//', '//date)
- ljob4 = ljob
- call printl('Opening '//infileq)
- open(18,file=infileq)
-c
-c Copy input file into common buffer
-c
- ipbuf = 0
- linewcom(1) = 1
- do 8 ilbuf = 1 , maxblks
- ncomments = 0
-14 read(18,'(a)',end=9)lnholdq
- lbuf(ilbuf) = lenstr(lnholdq,128)
- if (lbuf(ilbuf) .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lbuf(ilbuf) = 1
- lnholdq = ' '
- end if
-c
-c Now line has at least one non blank character. Check for comment
-c As of Version 260, do not copy comments into bufq
-c But need to count %'s for error messaging
-c if (lnholdq(1:1).eq.'%') go to 14
- if (lnholdq(1:1).eq.'%') then
- ncomments = ncomments+1
- go to 14
- end if
-c
-c When here, have counted all preceding comments and have a real line
-c
- if (ilbuf .gt. 1) then
- linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments
- else
- linewcom(1) = 1+ncomments
- end if
- if (ipbuf+lbuf(ilbuf).gt.65536) then
- print*,'Too many characters in file, stopping'
- call stop1()
- end if
- bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq
- ipbuf = ipbuf+lbuf(ilbuf)
-8 continue
- call printl('Too many lines in input file')
- call stop1()
-9 continue
-c
-c Insert dummy line to handle input files w/o CR-LF at end.
-c
- nlbuf = ilbuf-1
-c nlbuf = ilbuf
-c bufq(ipbuf+1:ipbuf+3) = ' / '
-c lbuf(nlbuf) = 3
- close(18)
- do 6 numit = 1 , maxit
- if (optimize) call printl('Starting an iteration')
-c
-c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0.
-c Otherwise, nbars0 is the input
-c When islast=.false., pmxb only returns poe's, otherwise does whole job
-c
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize)
- if (.not.optimize) then
- if (ismidi) then
-c
-c Set up channel numbers for midi.
-c
- numchan = 0
- do 11 iv = nv , 1 , -1
- if (twoline(iv)) then
- midchan(iv,2) = numchan
- numchan = numchan+1
- end if
- midchan(iv,1) = numchan
- numchan = numchan+1
-11 continue
-c
-c numchan will now be the number of channels, but max channel # is numchan-1
-c
-c Set up velocities, balances, and midi-transpositions
-c
- do 13 iv = nv , 1 , -1
- if (twoline(iv)) then
- midvelc(midchan(iv,2)) = midivel(iv)
- midbc(midchan(iv,2)) = midibal(iv)
- midtc(midchan(iv,2)) = miditran(iv)
- end if
- midvelc(midchan(iv,1)) = midivel(iv)
- midbc(midchan(iv,1)) = midibal(iv)
- midtc(midchan(iv,1)) = miditran(iv)
-13 continue
- end if
-c
-c TEMPORARY!!!
-c
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- do 10000 ilb = 1 , nlbuf
-c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb),
-c * bufq(ip1:ip1+lbuf(ilb)-1),
-c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)),
-c * k=min(3,lbuf(ilb)),1,-1)
- ip1 = ip1+lbuf(ilb)
-10000 continue
- iplast = ip1-1
-c
-c Check to see if (1) last line is "<blank><blank>/" 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 "<blank><blank>/"'
- write(15,*)'Removing last line of "<blank><blank>/"'
- nlbuf = nlbuf-1
- end if
- end if
-c
- call pmxb(.true.,poe0,ncalls,optimize)
- if (ismidi) then
-c
-c Write midi file
-c
- open(51,file=jobname(1:ljob)//'.mid')
- if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm')
- call printl(' ')
- call printl('Writing '//jobname(1:ljob)//'.mid')
- call writemidi(jobname,ljob)
- end if
- close(15)
- stop
- end if
- write(15,*)'nlbuf: ',nlbuf
- ip1 = 1
- call pmxb(.false.,poe0,ncalls,optimize)
- call poestats(nsyst,poe0,poebar0,devnorm0)
-c
-c Save initial deviation and line breaks for later comparison
-c
- if (numit .eq. 1) then
- devpmx = devnorm0
- do 20 isys = 1 , nsyst
- nbari(isys) = nbars0(isys)
-20 continue
- end if
- call sortpoe(nsyst,poe0,ipoe)
- do 1 iupord = nsyst , 1 , -1
- isysu = ipoe(iupord)
- print*,'isysu=',isysu
- write(15,*)'isysu=',isysu
-c
-c Skip if system isysu has poe0 < avg or isysd has poe0 > avg
-c
- if (poe0(isysu).lt.poebar0) go to 1
- do 5 idnord = 1 , nsyst
- isysd = ipoe(idnord)
- if (isysu.eq.isysd .or. nbars0(isysd).eq.1
- * .or. poe0(isysd).gt.poebar0) go to 5
- do 2 isyst = 1 , nsyst
- nbars(isyst) = nbars0(isyst)
- if (isyst .eq. isysu) then
- nbars(isyst) = nbars(isyst)+1
- else if (isyst .eq. isysd) then
- nbars(isyst) = nbars(isyst)-1
- end if
-2 continue
- call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize)
- call pmxb(.false.,poe,ncalls,optimize)
- call poestats(nsyst,poe,poebar,devnorm)
- if (devnorm .lt. devnorm0) then
- devnorm0 = devnorm
- poebar0 = poebar
- do 4 isys = 1 , nsyst
- nbars0(isys) = nbars(isys)
- poe0(isys) = poe(isys)
-4 continue
- print*,'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(15,*)'Improved with iup,idown,devnorm:',
- * isysu,isysd,devnorm0
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call sortpoe(nsyst,poe0,ipoe)
- go to 6
- end if
-5 continue
-1 continue
-c
-c If we get here, must have gone thru all switches and found nothing better,
-c so done!
-c
- go to 7
-6 continue
-7 continue
- print*,'Optimum located, numit:',numit,', ncalls:',ncalls
- write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls
- print*,'Final error:',devnorm0,', initial error:',devpmx
- write(15,*)'Final error:',devnorm0,', initial error:',devpmx
- print*,'Percentage improvement:',100.*(1-devnorm0/devpmx)
- write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx)
- call printl('Initial bars/system:')
- write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
- call printl('Final bars/system:')
- write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
- call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize)
- call pmxb(.true.,poe0,ncalls,optimize)
-c itend = mytime()
-c print*,'Elapsed time in ms:',itend-itstart
-c write(15,*)'Elapsed time in ms:',itend-itstart
- close(15)
- end
- subroutine accsym(nacc,acsymq,lacc)
- character*3 acsymq
- iacc = iand(nacc,7)
- if (iacc .eq. 1) then
- acsymq = 'fl'
- lacc = 2
- else if (iacc .eq. 2) then
- acsymq = 'sh'
- lacc = 2
- else if (iacc .eq. 3) then
- acsymq = 'na'
- lacc = 2
- else if (iacc .eq. 5) then
- acsymq = 'dfl'
- lacc = 3
- else if (iacc .eq. 6) then
- acsymq = 'dsh'
- lacc = 3
- else
- print*,'bad accidental: ',iacc
- end if
- return
- end
- subroutine addask(taskn,waskn,elaskn,
- * fixednew,scaldold,tglp1,isudsp)
- parameter (nm=24)
- logical isudsp
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comtol/ tol
- if (isudsp) then
-c
-c Find which udsp we're dealing with
-c
- do 1 iudsp = 1 , nudsp
- if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2
-1 continue
- print*,'You should note BEEE here in addask!'
- call stop1()
-2 continue
-c
-c Fixednew and scaldold must not be changed, since udsp's are already included
-c in fsyst from pmxa, and udsp don't involve scaled space..
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c Must add user-defined space to what's there already.
-c
- wask(naskb) = wask(naskb)+udsp(iudsp)
- else
-c
-c This place has no other space.
-c
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = udsp(iudsp)
- elask(naskb) = 0.
- end if
- else
-c
-c This is a normal space, no effect if smaller than existing space
-c
- if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
-c
-c We already put in some space at this time
-c Check if new one needs more space than old one at same time
-c
- if (waskn .gt. wask(naskb)) then
- naskb = naskb-1
- else
- return
- end if
- end if
- naskb = naskb+1
- task(naskb) = taskn
- wask(naskb) = waskn
- elask(naskb) = elaskn
- fixednew = fixednew+waskn
- scaldold = scaldold+elaskn
- end if
- return
- end
- subroutine addblank(noteq,lnoten)
- character*8 noteq
- character*1 tchar
- tchar = noteq
- noteq = ' '//tchar
- lnoten = 2
- return
- end
- subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd)
- parameter (nm=24)
- integer nfb(nm)
- common /comtol/ tol
- real*4 t1fb(nm,20),t2fb(nm,20)
- character*1 ulfbq(nm,20)
- ifbadd = 1
- nfb(iv) = nfb(iv)+1
- do 1 ifb = nfb(iv)-1 , 1 , -1
- if (tnew .lt. t1fb(iv,ifb)-tol) then
- t1fb(iv,ifb+1) = t1fb(iv,ifb)
- t2fb(iv,ifb+1) = t2fb(iv,ifb)
- ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
- else
- ifbadd = ifb+1
- go to 2
- end if
-1 continue
-2 continue
- t1fb(iv,ifbadd) = tnew
- ulfbq(iv,ifbadd) = 'x'
- return
- end
-c
-c
- subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest)
- parameter(nm=24,mv=24576)
- integer*2 mmidi,itk(25)
- integer*4 itiesav(5,100)
- character*1 notenumq
- logical endrest,eximacc,it1found
- logical rest
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- common /comdiag/ n69(0:nm),n34(0:nm)
-c
-c Following variables are local but must be saved. I hope they are.
-c (3/18/00) With g77 they are not, so add a common block here.
-c
-c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12)
- integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15)
- common /comips/ ipslon,lusebl,jusebl
-c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c
-c Cancel out barline accidentals if there's a rest.
-c
- if (rest) naccbl(icm) = 0
-c
-c Special path to insert dummy rest at end of a section
-c
- if (endrest) go to 20
-c
- do 7 ion = 0 , nmidcrd
-c
-c check if this is only to get pitch of a chord note
-c
- if (notmain) go to 6
-c
-c check for rest
-c
- if (rest) then
-c
-c Will not put in a note, but must update timing
-c
- if (.not.restpend(icm)) then
-c
-c First rest in sequence, save the time
-c
- restpend(icm) = .true.
- trest(icm) = time
- else
- trest(icm) = trest(icm)+time
- end if
-c
-c Note: code checkers don't like the above due to calling addmidi(trest(icm))
-c but this only happens if rest at end of section (endrest=.true.) (called
-c from getmidi(), in which case these above lines are bypassed.
-c
- call chkimidi(icm)
- return
- end if
-c
-c time tics
-c
- if (imidi(icm).gt.0 .and. ion.eq.0) then
- idur = mgap
- else
- idur = 0
- end if
- if (restpend(icm)) then
- restpend(icm) = .false.
- idur = idur+nint(15*trest(icm))
- end if
-c
-c time to start of note
-c
- idurvar = isetvarlen(idur,nby2on)
- if (nby2on .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- do 2 i = 1 , nby2on
-c
-c imidi points to cell before highest (leftmost) byte. Start with lowest byte
-c at far right, fill in backwards
-c
- mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256)
- if (nby2on .gt. 1) idurvar = idurvar/256
-2 continue
- imidi(icm) = imidi(icm)+nby2on-1
-c
-c Note-on signal
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 9*16+icm
- mmidi(icm,imidi(icm)) = 9*16+icmm(icm)
-c
-c Entry point for chord note pitch determination
-c
-6 continue
-c
-c Get midi pitch. On chord iteration, only do this first time (main note),
-c since pitch was already computed for nonmain chord notes.
-c
- if (ion .eq. 0) then
- ipsav = nolev*12./7+11
- ipsav0 = ipsav
- if (isig .ne. 0) then
-c
-c Adjust for signature
-c
- notenumq = char(48+mod(nolev,7))
- if (isig.ge.index('4152630',notenumq)) then
- ipsav = ipsav+1
- else if (-isig.ge.index('0362514',notenumq)) then
- ipsav = ipsav-1
- end if
- end if
-c
-c Deal with accidentals.
-c
-c iacc 0 1 2 3 4 5 6 7
-c effect X fl sh na X dfl dsh X
-c iashft X -1 1 0 X -2 2 X
-c
- jacc = 0
- eximacc = .false.
- if (iacc .gt. 0) then
-c
-c Adjust key-sig-adjusted pitch for explicit accidental (and exit)
-c
- jacc = iashft(iacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
-c
-c (Above) Shift applies to diatonic pitch but will be added to adjusted one
-c
- else if (naccim(icm) .gt. 0) then
-c
-c Possible implicit accidental from earlier in the bar
-c Check for prior accid in this bar at this note level
-c
- do 3 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- jacc = jaccim(icm,kacc)
- eximacc = .true.
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 4
- end if
-3 continue
-4 continue
- end if
-c
-c Must split off the following if block from those above because chord
-c notes can cause naccim>0, forcing us to miss other chord note's
-c accross-bar-line accidental
-c
- if (naccbl(icm).gt.0 .and. .not.eximacc) then
-c
-c Possible carryover accid from prior bar (or prior same-pitch note).
-c
- do 21 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev) then
- jacc = jaccbl(icm,kacc)
-c
-c Since we are *using* the bar-line accid, must flag it to be saved for next.
-c
- nusebl = nusebl+1
- jusebl(nusebl) = jacc
- lusebl(nusebl) = nolev
- if (.not.relacc) jacc = jacc+ipsav0-ipsav
- go to 22
- end if
-21 continue
-22 continue
- end if
- ipsav = ipsav+jacc
-c
-c Midi transpositions
-c
- ipsav = ipsav+midtc(icm)
- end if
- if (notmain) then
- mcpitch(nmidcrd) = ipsav
-c
-c Save pitch for tie checks
-c
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- imidi(icm) = imidi(icm)+1
- if (ion.eq.0) then
- mmidi(icm,imidi(icm)) = ipsav
- if (levson(icm).eq.nolev.and..not.slmon(icm))
- * ipslon(icm) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ion)
- end if
- end if
- if (ion .eq. 0) then
-c
-c Only record accids for non-chords, main chord note during chord iteration
-c and chordnotes on first call but not during iteration
-c
- if (iacc.gt.0) then
-c
-c Set marker for accidental for possible continuations later this bar
-c but first check and clear earlier ones on same note.
-c
- do 23 kacc = 1 , naccim(icm)
- if (laccim(icm,kacc) .eq. nolev) then
- do 24 macc = kacc , naccim(icm)-1
- laccim(icm,macc) = laccim(icm,macc+1)
- jaccim(icm,macc) = jaccim(icm,macc+1)
-24 continue
- go to 25
- end if
-23 continue
- go to 26
-25 continue
- naccim(icm) = naccim(icm)-1
-26 continue
-c
-c Flag new accidental
-c
- naccim(icm) = naccim(icm)+1
- laccim(icm,naccim(icm)) = nolev
- jaccim(icm,naccim(icm)) = iashft(iacc)
- end if
-c
-c Bail if this is a chord note on the first call (from docrd)
-c
- if (notmain) then
- call chkimidi(icm)
- return
- end if
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 127
- mmidi(icm,imidi(icm)) = midvelc(icm)
- call chkimidi(icm)
-7 continue
-c
-c For tie checks
-c
- if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm)
-c
-c Entry point for special rests at section ends (endrest=T)
-c
-20 continue
-c
-c Now insert all the ends
-c
- do 8 ioff = 0 , nmidcrd
- if (ioff .eq. 0) then
-c
-c time to end
-c
- idur1 = nint(15*time)
- if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then
- idur = idur1-mgap
- else
- idur = idur1
- end if
-c
-c Deal with roundoff problems with 7-tuplets on half or quarters
-c
- if (idur1 .eq. 69) then
- n69(icm) = n69(icm)+1
-c if (mod(n69(icm)+6,7) .gt. 3) idur = 58
- if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1
- else if (idur1 .eq. 34) then
- n34(icm) = n34(icm)+1
- if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1
- end if
- idurvar = isetvarlen(idur,nby2off)
- if (nby2off .gt. 4) then
- print*,'You got >4 bytes, something is bogus.'
- call stop1()
- end if
- imidi(icm) = imidi(icm)+1
- call chkimidi(icm)
- do 1 i = 1 , nby2off
- mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256)
- if (nby2off .gt. 1) idurvar = idurvar/256
-1 continue
- imidi(icm) = imidi(icm)+nby2off-1
- else
-c
-c Inserting end of chord note, delta time is 0
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- end if
-c
-c Note off
-c
- imidi(icm) = imidi(icm)+1
-c mmidi(icm,imidi(icm)) = 8*16+icm
- mmidi(icm,imidi(icm)) = 8*16+icmm(icm)
-c
-c Pitch
-c
- imidi(icm) = imidi(icm)+1
- if (ioff .eq. 0) then
- mmidi(icm,imidi(icm)) = ipsav
- else
- mmidi(icm,imidi(icm)) = mcpitch(ioff)
- end if
-c
-c Vel
-c
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = 0
- call chkimidi(icm)
- if (endrest) then
- return
- end if
-c
-c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time
-c
-8 continue
- naccbl(icm) = nusebl
- if (nusebl .gt. 0) then
-c
-c Fix tables of "bar-line" accids that are saved due to consecutive notes.
-c
- do 30 kacc = 1 , nusebl
- laccbl(icm,kacc) = lusebl(kacc)
- jaccbl(icm,kacc) = jusebl(kacc)
-30 continue
- nusebl = 0
- end if
-c
-c Begin tie checks
-c
- if (slmon(icm)) then
-c
-c Prior note had a slur start
-c
- if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then
-c
-c We have a tie! (Assumed there would be no accidental on tie-ending note)
-c Make a list of times of all events back to the one starting at imidso+1,
-c which is at or before where the tie started. Ident tie start and stop by
-c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie)
-c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial
-c time.
- nsav4tie = 0
- imidt = imidso(icm)
-10 nsav4tie = nsav4tie+1
- itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes)
- imidt = imidt+nbytes
- do 11 j = 1 , 3
- itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j)
-11 continue
- imidt = imidt+3
- if (nsav4tie .eq. 1) then
- itiesav(5,1) = itiesav(1,1)
- else
- itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+
- * itiesav(5,nsav4tie-1)
- end if
- if (imidt .ne. imidi(icm)) go to 10
-c
-c Find which two pitches agree with saved slur pitch.
-c
- it1found = .false.
- do 12 it2 = 1 , nsav4tie
- if (itiesav(3,it2) .eq. ipslon(icm)) then
- if (it1found) go to 13
- it1 = it2
- it1found = .true.
- end if
-12 continue
- call printl(
- * 'Program error, tied notes, send source to Dr. Don')
- it1 = nsav4tie+1
- it2 = nsav4tie+1
-13 continue
-c
-c List the positions we want to keep
-c
- jsav = 0
- do 14 isav = 1 , nsav4tie
- if (isav.eq.it1 .or. isav.eq.it2) go to 14
- jsav = jsav+1
- itk(jsav) = isav
-14 continue
- nsav4tie = nsav4tie-2
-c
-c Now dump events it1 & it2, recompute times, restack mmidi.
-c
- imidi(icm) = imidso(icm)
- do 15 isav = 1 ,nsav4tie
- if (isav .eq. 1) then
- idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes)
- else
- idurvar = isetvarlen(itiesav(5,itk(isav))-
- * itiesav(5,itk(isav-1)),nbytes)
- end if
- imidi(icm) = imidi(icm)+1
- do 16 i = 1 , nbytes
- mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256)
- if (nbytes .gt. 1) idurvar = idurvar/256
-16 continue
- imidi(icm) = imidi(icm)+nbytes-1
- do 17 i = 2 , 4
- imidi(icm) = imidi(icm)+1
- mmidi(icm,imidi(icm)) = itiesav(i,itk(isav))
-17 continue
-15 continue
- end if
- slmon(icm) = .false.
- levsoff(icm) = 0
- if (.not.dbltie) levson(icm) = 0
- end if
- if (levson(icm).gt.0) slmon(icm) = .true.
- if (nmidcrd .gt. 0) nmidcrd = 0
- call chkimidi(icm)
- return
- end
- subroutine addstr(notexq,lnote,soutq,lsout)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- character*(*) notexq
- character*80 soutq
- if (lsout+lnote .gt. 72) then
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- end if
- if (lsout .gt. 0) then
- soutq = soutq(1:lsout)//notexq(1:lnote)
- else
- soutq = notexq(1:lnote)
- end if
- lsout = lsout+lnote
- return
- end
- subroutine adjusteskz(ib,squez,istart,istop,poenom)
-c
-c For block ib, this adds accidental spaces to eskz, for use in getting
-c length of xtup bracket and slopes of brackets and beams.
-c
- parameter (nm=24)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- real*4 squez(80)
- integer*4 istart(80),istop(80)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comeskz2/ eskz2(nm,200)
- common /comtol/ tol
- common /comntot/ ntot
- inmin = istart(ib)+1
- do 10 iaskb = 1 , naskb
- if (task(iaskb) .lt. to(istart(ib))-tol) go to 10
- eskadd = wask(iaskb)/poenom-elask(iaskb)
- do 11 in = inmin , ntot
- if (to(in) .gt. task(iaskb)-tol) then
- eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd
- if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1
- else
- inmin = inmin+1
- end if
-11 continue
-10 continue
- return
- end
- subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- logical figbass,ispoi,topmods,istype0,done,isbbm
- common /comhsp/ hpttot(176)
- common /compoi/ ispoi
- common /combbm/ isbbm
- common /comas3/ ask(2500),iask,topmods
- character*40 pathnameq
- character*44 basenameq
- character*1 sq,chax
- character*129 outq
- sq = chax(92)
- open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex')
-c
-c Transfer first 5 lines of main internal TeX file
-c
- do 11 il = 1 , 5
- call moveln(11,12,done)
-11 continue
- if (istype0) then
-c
-c Transfer literal TeX stuff from special scratch file
-c
- rewind(17)
-10 call moveln(17,12,done)
- if (.not.done) go to 10
- close(17)
- end if
-c
-c Transfer next 2 lines from main scratch file
-c
- do 3 il = 1 , 2
- call moveln(11,12,done)
-3 continue
- if (ispoi) write(12,'(a)')sq//'input musixpoi'
- if (isbbm) write(12,'(a)')sq//'input musixbbm'
- if (figbass) then
-c
-c Transfer .fig data from scratch (unit 14) into external .tex (unit 12)
-c
-4 call moveln(14,12,done)
- if (.not.done) go to 4
- close(14)
- end if
- iask = 0
- ihs = 0
-1 read(11,'(a129)',end=999)outq
-c
-c Hardspaces.
-c
- if (outq(1:5) .eq. sq//'xard') then
- ihs = ihs+1
- outq(2:2) = 'h'
- write(outq(12:15),'(f4.1)')hpttot(ihs)
- lenout = 19
- go to 9
- end if
-c
-c This part hard-wires ask's into new .tex file as ast's
-c
-2 indxask = index(outq,sq//'ask')
- if (indxask .ne. 0) then
- iask = iask+1
- call putast(ask(iask),indxask,outq)
- go to 2
- end if
- lenout = llen(outq,129)
-9 continue
- write(12,'(a)')outq(1:lenout)
-c
-c If this is the line with "readmod", check for topmods.
-c
- if (topmods .and. outq(2:8).eq.'readmod') then
- topmods = .false.
- rewind(16)
- do 7 il = 1 , 1000
- read(16,'(a129)',end=8)outq
- lenout = llen(outq,129)
-c
-c We inserted the '%' in subroutine littex, to guarantee including blank.
-c
- write(12,'(a)')outq(1:lenout)
-7 continue
-8 continue
- close(16)
- end if
- go to 1
-999 close(11)
- close(12)
- return
- end
- subroutine backfill(iunit,oldq,lenold,newq,lennew)
-c
-c In iunit, looks backward for oldq, overwrites newq
-c Safest if both are same length!
-c
- character*128 lineq(200),nowq
- character*(*) oldq,newq
- linesback = 0
-1 continue
- backspace(iunit)
- read(iunit,'(a)')nowq
- ndx = index(nowq,oldq(1:lenold))
-c
-c Save the line just read
-c
- linesback = linesback+1
- lineq(linesback) = nowq
- if (ndx .eq. 0) then
- backspace(iunit)
- go to 1
- end if
-c
-c If here, it's replacement time.
-c
- lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew)
- * //nowq(ndx+lenold:128)
- backspace(iunit)
- do 2 line = linesback , 1 , -1
- write(iunit,'(a128)')lineq(line)
-2 continue
- return
- end
- subroutine beamend(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comoct/ noctup
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- character*4 tempq
- character*8 noteq
- character*79 notexq
- ip = ipo(jn)
- multip = iand(mult(ivx,ip),15)-8
- if (ixrest(ivx) .eq. 4) then
-c
-c This is the LAST note in the xtup (i.e., all rests before). Make single.
-c
- nodur(ivx,ip) = 2**(4-multip)
- call notex(notexq,lnote)
- ixrest(ivx) = 0
- return
- end if
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip-1),27))
- * nodur(ivx,ip)=nodur(ivx,ip)/2
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = lnoten+3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note is not regular-dotted
-c
-
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnote+1
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq
- lnote = lnote+2
- else if (multip .eq. -2) then
- notexq = sq//'wh'//noteq
- else if (multip .eq. -3) then
- notexq = sq//'breve'//noteq
- lnote = lnote+3
- else
- print*
- print*,'(Error in beamend, send source to Dr. Don)'
- call stop1()
- end if
- else
-c
-c Prior note is regular-dotted so this one is halved
-c
- if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
- end if
- end if
- end if
- return
- end if
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- lnote = 0
-c
-c New way, with flipend, which was computed in beamstrt.
-c
- if (flipend(ivx) .and. btest(ipl(ivx,ip),30))
- * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then
-c
-c This is not a one-noter from beam-jump. Check if multiplicity has increased
-c
- if (btest(irest(ivx,ip-1),0)) then
-c
-c Prior note is a rest, check one before that
-c
- mp = iand(mult(ivx,ip-2),15)-8
- else
- mp = iand(mult(ivx,ip-1),15)-8
- end if
- if (multip .gt. mp) then
-c
-c Assume 1-3, 2-3, or 1-2
-c
- do 2 imp = multip , mp+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
-2 continue
- else if (btest(nacc(ivx,ip-1),27)) then
-c
-c 2nd member of dotted xtup
-c
- call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
- end if
-c
-c Beam termination and direction analysis
-c
- if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then
-c
-c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number
-c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the
-c voice of the 2nd part of jumped beam. (May need special treatment for
-c multi-segment jump-beams
-c
- isbjmp = .true.
- ivbj1 = ivx
- ivbj2 = 0
- end if
- if (.not.btest(irest(ivx,ip),23)) then
-c
-c This is either a normal beamend or end of a sequence of jump-beam segments,
-c so some sort of termination is required
-c
- ulqq = ulq(ivx,ibmcnt(ivx))
- if (.not.isbjmp .or. ivx.ne.ivbj2) then
-c
-c Normal termination
-c
- call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote)
- else
-c
-c Terminate a sequence of jump-beam segments.
-c
- ulqq = chax(225-ichar(ulqq))
- call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote)
- end if
- end if
-c
-c And now the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (.not.btest(iornq(ivx,ip),13)) then
- notexq = notexq(1:lnote)//'p'
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
-c
-c 5/25/08 Allow >12
-c 5/9/10 Up to 24; replace 24 with 0
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
-c call istring(mod(ivx,12),tempq,len)
- call istring(mod(ivx,24),tempq,len)
- else
-c call istring(mod(ivbj1,12),tempq,len)
- call istring(mod(ivbj1,24),tempq,len)
- end if
- if (isbjmp .and. ivx.eq.ivbj2
- * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false.
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamid(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq,ulqq,chax
- logical beamon,firstgulp,figbass,figchk,flipend,btest,
- * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm
- character*79 notexq
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- character*8 noteq
- character*4 tempq
- lnote = 0
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- multip = iand(mult(ivx,ip),15)-8
-c if (btest(islur(ivx,ip-1),3)) multip = multip+1
-c
-c (Above test OK since must have ip>1). Double dotted note preceding
-c
-c Move the following, because can't ask for note until after checking for
-c embedded xtup with number, due to ordering/octave feature.
-c
-c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
- end if
- if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true.
- if (vxtup(ivx)) then
-c
-c In an xtup
-c
- if (btest(irest(ivx,ip),0)) then
-c
-c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK
-c
- nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8))
- call notex(notexq,lnote)
-c
-c Re-zero so next note does not get confused
-c
- nodur(ivx,ip) = 0
- return
- end if
-c if (multip.le.0) then
-c if (multip.le.0 .or.
-c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip)
- nodur(ivx,ip) = 2**(4-multip)
- if (btest(nacc(ivx,ip),19) .or.
- * btest(nacc(ivx,ip),27)) then
- nodur(ivx,ip)=3*nodur(ivx,ip)/2
- else if (btest(nacc(ivx,ip-1),27)) then
- nodur(ivx,ip)=nodur(ivx,ip)/2
- end if
- call notex(notexq,lnote)
- nodur(ivx,ip) = ndsav
- else
-c
-c Use ulq for stem direction
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (.not.btest(nacc(ivx,ip-1),27)) then
-c
-c Prior note is not regular-dotted
-c
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- end if
- if (btest(nacc(ivx,ip),27)) then
-c
-c This note is regular dotted non-beamed xtup
-c
- notexq = notexq(1:3)//'p'
- lnote = 4
- end if
- else
-c
-c Prior note is regular-dotted so this one is halved
-c
- if (multip .eq. 0) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -2) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- end if
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- else if (nodur(ivx,ip).eq.0) then
-c
-c In the beamed xtup but not the last note
-c
- if (nodur(ivx,ip-1).gt.0) then
-c
-c Embedded Xtup, mult>0, starts here. Put in number if needed
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- iud = 1
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1
-c
-c Get ip#, notelevel of middle note (or gap) in xtup
-c
- ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ip),14)) then
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Place number if needed
-c
- if (.not.btest(islur(ivx,ip),31)) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
- call putxtn(mprint,iflop,multip,iud,wheadpt,poenom,
- * nolev1(ivx),islope(ivx),slfac,
- * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
- * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.)
- end if
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- else
-c
-c Intermediate note of xtup
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else
-c
-c Last note of xtup (but not last note of beam!)
-c
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
- else if (btest(irest(ivx,ip),0)) then
- call notex(notexq,lnote)
- return
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- end if
-c
-c Check if multiplicity changes in a way requiring action
-c
- ipleft = ip-1
- if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
- if (.not.btest(islur(ivx,ipleft),20)) then
- multl = iand(15,mult(ivx,ipleft))-8
- else
- multl = 1
- end if
- mub = multip - multl
- ipright = ip+1
- if (btest(irest(ivx,ipright),0)) ipright = ipright+1
- if (.not.btest(islur(ivx,ip),20)) then
- multr = iand(15,mult(ivx,ipright))-8
- else
- multr = 1
- end if
- mua = multr-multip
- if (mub.gt.0 .or. mua .lt. 0) then
-c
-c Multiplicity has increased from left or will decrease to right. Need action.
-c
- if (isbjmp .and. ivx.eq.ivbj2) then
- ivb = ivbj1
- ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
- else
- ivb = ivx
- ulqq = ulq(ivx,ibmcnt(ivx))
- end if
- if (mua .ge. 0) then
- call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote)
- else if (multl .ge. multr) then
- do 1 im = multip , 1+multr, -1
- call ntrbbb(im,'t',ulqq,ivb,notexq,lnote)
-1 continue
- else
- do 2 im = 1+multr, multip
- call ntrbbb(im,'r',ulqq,ivb,notexq,lnote)
-2 continue
- call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote)
- end if
- else if (ip .gt. 1) then
-c
-c Check for 2nd member of dotted xtup
-c
- if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t',
- * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
- end if
-c
-c Now put in the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
- isdotm = .false.
- if (isdotted(nodur,ivx,ip)) then
-c
-c rule out ')'
-c
- if (.not.btest(iornq(ivx,ip),13)) then
- if (.not.btest(islur(ivx,ip),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- else if (btest(nacc(ivx,ip),19)
- * .or. btest(nacc(ivx,ip),27)) then
-c
-c Special dotted notation for 2:1 xtup, or normal dot in xtup
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c 5/25/08 Allow >12
-c
- if (.not.(isbjmp.and.ivx.eq.ivbj2)) then
-c call istring(mod(ivx,12),tempq,len)
- call istring(mod(ivx,24),tempq,len)
- else
-c call istring(mod(ivbj1,12),tempq,len)
- call istring(mod(ivbj1,24),tempq,len)
- end if
- notexq = notexq(1:lnote)//tempq(1:len)
- lnote = lnote+len
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamn1(notexq,lnote)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm
- common /comoct/ noctup
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*8 noteq
- character*79 notexq
- ip1 = ipo(jn)
- multip = iand(15,mult(ivx,ip1))-8
-c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then
- if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then
- lnote = 0
-c
-c The rest was already written in beamstrt, so just get out of here
-c
- return
- end if
- nole = nolev(ivx,ipo(jn))
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ipo(jn)),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ipo(jn)),31)) then
- nole = nole + 1
- end if
- if (vxtup(ivx) .and. .not.drawbm(ivx)) then
-c
-c Xtuplet with no beam, just put in the right kind of note
-c
- if (btest(islur(ivx,ip1),30)) then
-c
-c Forced stem direction
-c
- ndsav = nodur(ivx,ip1)
- nodur(ivx,ip1) = 2**(4-multip)
- if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2
- call notex(notexq,lnote)
- nodur(ivx,ip1) = ndsav
- else
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- lnote = 3
- if (multip .eq. 0) then
- notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. -1) then
- notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 1) then
- notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))
- else if (multip .eq. 2) then
- notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))
- lnote = 4
- else if (multip .eq. 3) then
- notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))
- lnote = 5
- else if (multip .eq. -2) then
- notexq = sq//'wh'
- else if (multip .eq. -3) then
- notexq = sq//'breve'
- lnote = 6
- else
- print*
- print*,'(Error in beamn1, send source to Dr. Don)'
- call stop1()
- end if
- if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then
- notexq = notexq(1:3)//'p'
- lnote = 4
- end if
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- end if
- return
- end if
-c
-c Check if mult. decreases from 1st note to 2nd
-c
- if (ibm2(ivx,ibmcnt(ivx)).gt.ip1
- * .or. btest(islur(ivx,ip1),20)) then
-c
-c More than one note or single-note before a multiplicity-down-up "]["
-c
- if (btest(islur(ivx,ip1),20)) then
- multr = 1
- else if (.not.btest(irest(ivx,ip1+1),0)) then
- multr = iand(15,mult(ivx,ip1+1))-8
- else
- multr = iand(15,mult(ivx,ip1+2))-8
- end if
- lnote = 0
- if (multr .lt. multip) then
- do 1 im = multip , multr+1 , -1
- call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
-1 continue
- end if
- end if
-c
-c Put in the note
-c
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'qb'
- else
- notexq = sq//'qb'
- end if
- lnote = lnote+3
-c
-c Check for dot
-c
- isdotm = .false.
- if (.not.vxtup(ivx)) then
- nd = nodur(ivx,ipo(jn))
- if (nd.ne.0) then
- if (2**log2(nd).ne.nd) then
- if (.not.btest(iornq(ivx,ip1),13)) then
- if (.not.btest(islur(ivx,ip1),3)) then
- notexq = notexq(1:lnote)//'p'
- else
-c
-c Double dot
-c
- notexq = notexq(1:lnote)//'pp'
- lnote = lnote+1
- end if
- else
- notexq = notexq(1:lnote)//'m'
- isdotm = .true.
- end if
- lnote = lnote+1
- end if
- end if
- else if (btest(nacc(ivx,ip1),19) .or.
- * btest(nacc(ivx,ip1),27)) then
-c
-c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
-c
-c Do the number; 0 if 12
-c
-c 5/25/08 allow >12
-c
- if (.not.btest(irest(ivx,ip1),24)) then
-c call istring(mod(ivx,12),noteq,len)
- call istring(mod(ivx,24),noteq,len)
- else
-c call istring(mod(ivbj1,12),noteq,len)
- call istring(mod(ivbj1,24),noteq,len)
- end if
- notexq = notexq(1:lnote)//noteq(1:len)
- lnote = lnote+len
- call notefq(noteq,lnoten,nole,ncmid(iv,ip1))
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (isdotm) then
- if (lnoten .eq. 1) then
- notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- return
- end
- subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- character*79 inameq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm
- common /comeskz2/ eskz2(nm,200)
- common /comoct/ noctup
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c The following is just to save the outputs from SetupB for the case of
-c xtups starting with a rest, where beamstrt is called twice.
-c
- common /comipb/ nnb,sumx,sumy,ipb(24),smed
- character*8 noteq
- character*79 notexq,tempq
- integer nornb(nm),ihornb(nm,24)
- real*4 space(80),squez(80)
- logical novshrinktop,cstuplet,usexnumt
- common /comnvst/ novshrinktop,cstuplet
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figq
- ibc = ibmcnt(ivx)
- ipb1 = ibm1(ivx,ibc)
- multb = iand(15,mult(ivx,ipb1))-8
- ip = ipo(jn)
-c
-c Compute slopes and note offsets from start of beam. Inside SetupB, for each
-c xtup in the beam, set eloff,mtupv (in comxtup) for printed number.
-c
- if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21))
- * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx))
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is start of later segment of single-slope beam group so use slope and
-c height from prior beam. Slope is already OK.
-c
- issb(ivx) = issb(ivx)+1
- nolev1(ivx) = lev1ssb(ivx,issb(ivx))
- end if
- lnote = 0
- drawbm(ivx) = .true.
- if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then
- vxtup(ivx) = .true.
- nxtinbm(ivx) = nxtinbm(ivx)+1
-c
-c irest(28)=>Xtup starts on this note. Set up for xtuplet.
-c Number goes on notehead side at middle note (or gap) of xtup, unless that
-c puts it in staff, then it flops to stem (or beam) side.
-c __ __
-c | | | O | |
-c O | | O
-c |___| O |__| |
-c
-c iud -1 -1 1 1 ...stem direction
-c iflop 0 1 -1 0 ...direction of flop
-c iup -1 1 -1 1 ...direction of number and bracket
-c
- iud = 1
- if (ulq(ivx,ibc) .eq. 'u') iud = -1
-c
-c Get ip#, note level of middle note (or gap) in xtup
-c
- ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2
- xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
- * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+
- * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
- * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2
- iflop = 0
- if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud
- iup = iud+2*iflop
- if (btest(irest(ivx,ipb1),14)) then
-c
-c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic)
-c
- iup = -iup
- iflop = 0
- if (iud*iup .lt. 0) iflop = iup
- end if
-c
-c Determine if a beam is to be drawn
-c
- do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc)
- if (iand(15,mult(ivx,ipp))-8 .le. 0) then
- drawbm(ivx) = .false.
- go to 6
- end if
-5 continue
- drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18)
-6 continue
-c
-c Are we using tuplet.tex?
-c
- usexnumt = cstuplet .and. .not.drawbm(ivx)
-c
-c Place xtup number if needed
-c
- if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then
- mprint = igetbits(nacc(ivx,ip),5,22)
- if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx))
- call putxtn(mprint,iflop,multb,iud,wheadpt,
- * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1),
- * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)),
- * iup,irest(ivx,ipb1),usexnumt)
- end if
- if (.not.drawbm(ivx)) then
-c
-c Xtuplet with no beam
-c
- if (.not.btest(islur(ivx,ipb1),31)) then
-c
-c Number printing has not been suppressed, so put in the bracket.
-c scale = stretch factor for bracket if there are asx's
-c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon)
-c
- xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1)
- * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib))
- if (iup .eq. 1) then
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'ovbkt'
- else
- notexq = sq//'ovbkt'
- end if
- else
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//sq//'unbkt'
- else
-c
-c Introduced 12/5/98, req'd due to possible presence of in-line TeX
-c
- notexq = sq//'unbkt'
- end if
- end if
- lnote = lnote+6
- if (iline.eq.1) then
- smed = smed/(1.-fracindent)
- end if
- xslope = 1.8*smed*slfac
- islope(ivx) = nint(xslope)
- nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1))
- if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1
- if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4
- levbracket = nolev1(ivx)
- if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1
- call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
- if (xnsk .lt. 0.995) then
- write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk
- lnote = lnote+4
- else if (xnsk .lt. 9.995) then
- write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk
- lnote = lnote+5
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- if (btest(mult(ivx,ipb1),4)) then
-c
-c Tweak slope of bracket
-c
- islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16
- end if
- if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (islope(ivx) .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx)
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx)
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx)
- lnote = lnote+1
- end if
-c
-c Done with bracket
-c
- end if
- if (ixrest(ivx) .eq. 1) then
-c
-c Put in the rest. Possible problem: Rest is a spacing char, but between
-c beamstrt and beamn1 some non-spacing chars. are inserted.
-c
- if (multb .eq. 0) then
- notexq = notexq(1:lnote)//sq//'qp'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.1) then
- notexq = notexq(1:lnote)//sq//'ds'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.2) then
- notexq = notexq(1:lnote)//sq//'qs'
- lnote = lnote+3
- else if (.not.drawbm(ivx).and.multb.eq.3) then
- notexq = notexq(1:lnote)//sq//'hs'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//sq//'hpause'
- lnote = lnote+7
- end if
-c
-c No need to come back through this subroutine (as would if rest starts bar
-c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing.
-c
- ixrest(ivx) = 0
- end if
- return
- end if
-c
-c End if block for non-beamed xtup start...note we returned
-c
- if (ixrest(ivx) .eq. 1) then
-c
-c Insert rest at start of beamed xtup. See above note for possible problem.
-c
- nodur(ivx,ipb1) = 2**(4-multb)
- call notex(tempq,ltemp)
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//tempq(1:ltemp)
- else
- notexq = tempq(1:ltemp)
- end if
- lnote = lnote+ltemp
-c
-c Re-zero just in case!
-c
- nodur(ivx,ipb1) = 0
- ibm1(ivx,ibc) = ibm1(ivx,ibc)+1
-c
-c See if next note is a non-rest
-c
- if (.not.btest(irest(ivx,ipb1+1),0)) then
- ixrest(ivx) = 2
- else
-c
-c Suppress reprinting xtup number next time through beamstrt
-c
- islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31)
-c
-c Set new xtup start flag
-c
- irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28)
- end if
- return
- end if
- end if
-c
-c Just ended if block for xtups
-c
- if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then
-c
-c Move actual note writing to beamend
-c
- ixrest(ivx) = 4
- return
- end if
- if (issb(ivx) .eq. 0) then
-c
-c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed
-c
- iadj = igetbits(ipl(ivx,ipb1),6,11)-30
- if (iadj .ne. -30) then
- nolev1(ivx) = nolev1(ivx)+iadj
- do 2 isssb = 1 , nssb(ivx)
- lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj
-2 continue
- end if
- iadj = igetbits(ipl(ivx,ipb1),6,17)-30
- if (iadj .ne. -30) then
- islope(ivx) = islope(ivx)+iadj
- if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx))
- if (nssb(ivx) .gt. 0) then
-c
-c Cycle thru non-rest notes in SSBG, looking for bmstrts.
-c
- isssb = 0
- do 4 inb = 2, nnb
- if (btest(nacc(ivx,ipb(inb)),21)) then
-c
-c Beam segment start. New start level
- isssb = isssb+1
- lev1ssb(ivx,isssb) =
- * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac
- end if
-4 continue
- end if
- end if
- end if
- iadj = igetbits(islur(ivx,ipb1),2,27)
- addbrack = .false.
- if (btest(ipl(ivx,ipb1),30)) then
-c
-c Check for altered starting polarity. Only in forced beams. Nominal start
-c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.).
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'loff{'
- else
- notexq = notexq(1:lnote)//sq//'loff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- else if (ulq(ivx,ibc).eq.'l' .and.
- * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then
- if (lnote .eq. 0) then
- notexq = sq//'roff{'
- else
- notexq = notexq(1:lnote)//sq//'roff{'
- end if
- lnote = lnote+6
- addbrack = .true.
- end if
-c
-c Check end level for possible flipping in forced beam. Have to do it
-c here since with multiple voices, xelsk will not be preserved.
-c
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
- bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
- else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then
- bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac
- flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
- end if
- end if
- call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote)
-c
-c Put in name of start level and slope, after correcting nolev1 if xtup
-c started with a rest.
-c
- if (ixrest(ivx).eq.2) nolev1(ivx) =
- * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac)
- call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1))
- if (islope(ivx) .lt. 0) then
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+4+lnoten
- write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}'
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- write(notexq(lnote:lnote),'(i1)')islope(ivx)
- end if
-c
-c Check for beam-thk fine-tuning
-c
- if (iadj .gt. 0) then
- do 1 imp = multb+iadj , multb+1 , -1
- call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
-1 continue
- end if
-c
-c If we shifted, must close with right bracket
-c
- if (addbrack) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Get 'floor' zmin for figures
-c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height
-c won't be adjusted. If anyone ever needs that, need to duplicate this
-c functionality up above, before exiting.
-c
- if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then
- if (ivx .eq. 1) then
- ivf = 1
- else
- ivf = ivxfig2
- end if
- zmult = 1.2*(multb-1)
- ymin = 100.
- do 3 inb = 1, nnb
- if (isfig(ivf,ipb(inb))) then
- if (ulq(iv,ibc) .eq. 'u') then
- ybot = nolev(iv,ipb(inb))
- else
- ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx)
- * -stemlen-zmult
- end if
- ymin = min(ymin,ybot)
- end if
-3 continue
- maxdrop = ncmid(iv,ipb1)-4-ymin+5.01
- ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop)
- end if
-c
-c Compute ornament levels if needed
-c
- NomOrnLev = ncmid(iv,ipb1)+5
- iorn = 0
- do 8 inb = 1 , nnb
- ip = ipb(inb)
- if (.not.btest(iornq(ivx,ip),23)) go to 8
- if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then
-c
-c letter-dynamic or hairpin ending under down-beamed
-c
- iorn = iorn+1
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- else if (.not.btest(ipl(ivx,ip),10)) then
-c
-c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD
-c
-c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if
-c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.)
-c
- if (ulq(ivx,ibc).eq.'u' .and.
- * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then
- iorn = iorn+1
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- end if
- else
-c
-c In a chord. Orn may be on main note or non-main or both. Set ihornb if
-c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note
-c
- do 10 icrd1 = 1 , ncrd
- if (iand(255,icrdat(icrd1)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11
-10 continue
-11 continue
-c
-c Find outermost note, min or max depending on beam direction ulq. xto is true
-c if there's an ornament on that note. Expand orn list to include ._, since if
-c on extreme chord note in beam, will move.
-c So ornaments are all except 0,4,13 (,g,)
-c
- levx = nolev(ivx,ip)
- xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0
- icrdx = 0
- do 12 icrd = icrd1 , ncrd
- if (iand(255,icrdat(icrd)) .ne. ip .or.
- * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13
- levc = iand(127,ishft(icrdat(icrd),-12))
- if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or.
- * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then
- levx = levc
- icrdx = icrd
- xto = iand(icrdorn(icrd),4186094).gt.0
- end if
-12 continue
-13 continue
-c
-c If there's orn on extreme note, do stuff
-c
- if (xto) then
- iorn = iorn+1
- if (ulq(ivx,ibc) .eq. 'u') then
- ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
- * +1.2*(multb-1)
- ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
- else
- ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
- * -1.2*(multb-1)
- ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
- end if
- if (icrdx .eq. 0) then
-c
-c Affected ornament is on main note
-c
- iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
- else
- icrdorn(icrdx) = ibset(icrdorn(icrdx),22)
- end if
- end if
- end if
-8 continue
-c
-c Henceforth nornb will be a counter.
-c
- if (iorn .gt. 0) nornb(ivx)=1
- if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0
- return
- end
- block data
- parameter (nm=24)
- common /comtol/ tol
- common /comtrans/ cheadq
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- logical usefig
- common /comstart/ facmtr
- character*60 cheadq
- character*120 instrq,titleq,compoq
- logical headlog
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /combmh/ bmhgt,clefend
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
-c
- data tol /.001/
- data cheadq
- * /' '/
- data gslfac /9./
- data instrq,titleq,compoq,headlog /3*' ',.false./
-c
-c meter space (pts) = xb4mbr = musicsize*facmtr
-c
- data facmtr /0.55/
- data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt
- * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 ,
- * .7,.7 ,.9 ,.5 ,2.3 ,1.1 /
- data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac
- * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 /
- data rtshfac / 1.0 /
- data isize /nm*0/
-c
-c From other
-c
- data ptheight,widthpt,
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh
- * / 740. , 524. ,
- * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12.,
- * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 /
- data fracsys /30*0./
- data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1,
-c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6,
- * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3,
- * -0.3,0.3 /
- data kbdrests /.false./,
- * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/
- data EarlyTransOn, LaterInstTrans /2*.false./
- data iInstTrans /nm*0/
- end
- subroutine catspace(space,squez,nnsk)
- parameter (nkb=3999,maxblks=4000)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /comtol/ tol
- logical gotclef
- do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
- if (abs(space-durb(iptr)) .lt. tol) then
- if (abs(squez-sqzb(iptr)) .lt. tol) then
-c
-c Increment pre-existing entry
-c
- nnpd(iptr) = nnpd(iptr)+nnsk
- return
- end if
- end if
-16 continue
-c
-c Didn't find current duration & squez, so add a new entry.
-c No particular reason to keep in order, so add at the end.
-c
- nnpd(nptr(ibarcnt+1)) = nnsk
- durb(nptr(ibarcnt+1)) = space
- sqzb(nptr(ibarcnt+1)) = squez
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- return
- end
- character*1 function chax(n)
-c
-c The only reason for this seemingly do-nothing function is to get around an
-c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler!
-c
- chax = char(n)
- return
- end
- subroutine checkdyn(lineq,iccount,ibar)
- character*128 lineq
- character*1 durq,chax
- character*4 dynsymq
- logical txtdyn
- txtdyn = .false.
-c
-c On entry, iccount is on "D"
-c
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c Dynamic text
-c
- iend = index(lineq(iccount+2:128),'"')
- if (iend .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,
- * 'Dynamic text must be terminated with double quote!')
- call stop1()
- end if
-c
-c Set iccount to character after 2nd ", and set ipm
-c
- iccount = iccount+iend+2
- ipm = index('- +',lineq(iccount:iccount))
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "-", "+", or blank here!')
- call stop1()
- end if
- else
-c
-c Expect ordinary dynamic
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then
- call errmsg(lineq,iend-1,ibar,
- * 'Wrong length for dynamic mark!')
- call stop1()
- end if
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ',
- * dynsymq)+3)/4
- if (idno .eq. 0) then
- call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!')
- call stop1()
- end if
- iccount = iend
- end if
- if (ipm .ne. 2) then
-c
-c There is a vertical shift, have "+" or "-"
-c
- iccount = iccount+1
- if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected integer here for vertical offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- if (idno .gt. 63) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Vertical offset for dynamic mark must be (-63,63)!')
- call stop1()
- end if
- ipm = index('- +',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected "+", "-", or blank here!')
- call stop1()
- end if
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
- iccount = iccount+1
- if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then
- call errmsg(lineq,iccount,ibar,
- * 'Expected number here for horizontal offset!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- if (idno .gt. 255) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!')
- call stop1()
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,
- * 'There should be a blank here!')
- call stop1()
- end if
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- return
- end
- subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
-c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp,
-c * icashft)
- logical found1,iscacc,isarp,btest
- integer icrdat(193)
- found1 = .false.
-c
-c icashft will be max left shift of accid's in chord notes.
-c Used only for spacing checks.
-c Will include left shift of chord note itself.
-c Rezero after use.
-c
- do 18 icrd = 1 , ncrd
-c
-c This if block cycles thru all chord notes on ivx,ip; then returns.
-c
- if (iand(255,icrdat(icrd)) .eq. ip .and.
- * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
- found1 = .true.
- iscacc = iscacc .or.
- * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27))
-c
-c Accid on this chord note, and it's not midi-only.
-c
-c irshft = igetbits(icrdot(icrd),7,20)
-cc
-cc Include increment for notehead shift
-cc
-c if (btest(icrdat(icrd),23)) then
-c if (irshft .eq. 0) then
-c irshft = 44
-c else
-c irshft=irshft-20
-c end if
-c end if
-c if (irshft .ne. 0) then
-cc
-cc Accid on chord note is shifted. Include only left shift, in 20ths.
-cc
-c if (irshft .lt. 64) icashft = max(icashft,64-irshft)
-c end if
-c end if
- isarp = isarp .or. btest(icrdat(icrd),25)
- else if (found1) then
- return
- end if
-18 continue
- return
- end
- subroutine chkimidi(icm)
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- if (imidi(icm) .ge. mv) then
- print*
- print*,'Midi file is too long! It will be corrupted or worse'
- write(*,'(a6,2x,4i8)')
- * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3)
- end if
- return
- end
- subroutine chklit(lineq,iccount,literr)
- character*128 lineq
- character*1 charq,chax
- literr = 0
- itype = 1
-17 call g1etchar(lineq,iccount,charq)
- if (charq .eq. chax(92)) then
- itype = itype+1
-c if (itype .eq. 2) then
-c if (iccount .ne. 2 ) then
-cc
-cc type 2 or 3 tex string not starting in column 1
-cc
-c literr = 3
-c return
-c end if
-c else if (itype .gt. 3) then
- if (itype .gt. 3) then
- literr = 1
- return
- end if
- go to 17
- end if
- lenlit = itype
-18 call g1etchar(lineq,iccount,charq)
- if (charq.eq.chax(92)) then
- call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
-c
-c Starting a new tex command withing the string
-c
- lenlit = lenlit+2
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- else
- lenlit = lenlit+1
- if (lenlit .gt. 128) then
- literr = 2
- return
- end if
- go to 18
- end if
- return
- end
- subroutine chkpm4ac(lineq,iccount,nacc,moved)
-c
-c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>.
-c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits
-c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed
-c numbers. If moved=.true., iccount on exit is on end of last number.
-c If moved=.false., iccount still on +/-
-c
- logical moved,ishorz
- character*128 lineq
- character*1 durq
- if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and.
- * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then
-c
-c Prior char was accid & next is #; this may be start of accidental shift.
-c Must test for "." above in case we get "<" or ">"
-c
- ipm = index('- +< >',lineq(iccount:iccount))-2
- if (lineq(iccount+1:iccount+1).eq.'.' .and.
- * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then
-c
-c Rare case of [accid][+/-].[letter]. Bail out
-c
- moved = .false.
- return
- end if
- ishorz = ipm .gt. 1
-c
-c Save iccount in case it's not accid shift and we have to reset.
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (ishorz .or. index('+-',durq).gt.0) then
-c
-c This has to be accidental shift. Set vert. shift.
-c
- if (.not.ishorz) then
-c
-c +/- syntax, both shifts set, vertical first
-c
- call setbits(nacc,6,4,int(ipm*fnum+32.5))
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else
-c
-c </> syntax, only horiz set
-c
- ipm = ipm-3
- end if
-c
-c Set horiz. shift
-c
- call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35)))
- iccount = iccount-1
- moved = .true.
- else
-c
-c False alarm. Reset everything and flow onward
-c
- moved = .false.
- iccount = icsav
- end if
- else
-c
-c Either prior char was not 'sfn' or next was not digit, so take no action
-c
- moved = .false.
- end if
- return
- end
- subroutine clefsym(isl,notexq,lnote,nclef)
-c
-c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs.
-c
- character*(*) notexq
- character*1 chax
- nclef = iand(ishft(isl,-12),7)
- if (nclef .eq. 0) then
-c
-c treble
-c
- nlev = 2
- else if (nclef .gt. 6) then
-c
-c French violin
-c
- nlev = 0
- else if (nclef .lt. 5) then
-c
-c C-clef
-c
- nlev = 2*nclef-2
- else
-c
-c F-clef
-c
- nlev = 2*nclef-6
- end if
- notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7))
- * //chax(48+nlev)
- lnote = 10
- return
- end
- subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c micrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c segrb(1|2,.) x|y-coord of right-bdry segment
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c icrdot0 = top-down level-rank of main note among accid-notes
-c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes
-c twooftwo will be true 2nd time thru; signal to store shifts w/ notes
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50)
- integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50),
- * isetshft(10),ksegrb0(50)
- logical lasttime,mainnote,twooftwo
- data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 /
- data segar /
-c
-c Fancy sharp boundary. fl,sh,na,dfl,dsh
-c
- * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2,
-c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. ,
-c meas value for y, natural is 1.6
- * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2,
- * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
- data segal /
-c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. ,
-cc (meas. value is 3.08) ^^^^
-cc Raise top of flat so it interferes with bottom of sharp
- * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2,
- * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2,
- * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. ,
- * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. ,
- * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. /
-c
-c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6)
-c
- data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 /
-c
-c Set up barrier segrb(iseg,ipoint) to define coords of corner points
-c on stem+notes
-c
- do 11 iseg = 1 , nsegrb0
- segrb(1,iseg) = segrb0(1,iseg)
- segrb(2,iseg) = segrb0(2,iseg)
- ksegrb(iseg) = ksegrb0(iseg)
-11 continue
- nsegrb = nsegrb0
- rmsshift = 0.
- shiftmin = 1000.
- do 1 iwa = 1 , naccid
-c
-c Initialize shift for this note
-c
- shift = 0.
- mainnote = micrd(iwa).eq.0
- isetshft(iwa) = -1
-c
-c Get note level and accidental type
-c
- if (mainnote) then
- nolev = nolevm
- iacctype = iacctbl(igetbits(nacc,3,0))
- else
- nolev = igetbits(icrdat(micrd(iwa)),7,12)
- iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20))
- end if
-c
-c Cycle thru segments on right edge of this accidental
-c
- do 2 isega = 1 , nsegar(iacctype)-1
- ybotaseg = nolev+segar(iacctype,2,isega)
- ytopaseg = nolev+segar(iacctype,2,isega+1)
-c
-c Cycle thru segments of right-hand barrier
-c
- do 3 isegrb = 1 , nsegrb-1
-c
-c Must find all barrier segments that start below ytopseg & end above ybotseg
-c
- if (segrb(2,isegrb) .lt. ytopaseg) then
-c
-c Barrier seg starts below top of accid
-c Check if barrier seg ends above bottom of accid
-c
- if (segrb(2,isegrb+1) .gt. ybotaseg) then
- if (shift .gt.
- * segrb(1,isegrb)-segar(iacctype,1,isega)) then
- shift = segrb(1,isegrb)-segar(iacctype,1,isega)
-c
-c Record the cause of the shift
-c
- isetshft(iwa) = ksegrb(isegrb)
- end if
- end if
-c
-c Does barrier segment end above top of accid seg?
-c
- if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4
- end if
-3 continue
-4 continue
-2 continue
- if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001
- * .and. .not.lasttime) then
-c if (nolev .eq. levmaxacc) then
- if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then
- rmsshift = 1000.
- return
- end if
-c
-c Does the following properly account for left-shifted noteheads?
-c
-c Top-down rank of this note we just shifted
-c
- if (mainnote) then
- irank = icrdot0
- else
- irank = igetbits(icrdot(micrd(iwa)),3,27)
- end if
-c
-c Compare level-rank of this note vs. that of note that caused the shift.
-c This has effect of checking for basic interferences from top down.
-c
-c ksegrb(.) internal use; tells what defined this segment
-c -2: Left-shifted notehead
-c -1: Original right boundary
-c 0: Main note accidental
-c icrd: Chord-note accidental
-c isetshft(i),i=1,naccid: what set shift for this accid, same codes
-c
- if (isetshft(iwa) .lt. 0) then
- iranksetter = 0
- else if (isetshft(iwa) .eq. 0) then
- iranksetter = icrdot0
- else
- iranksetter = igetbits(icrdot(isetshft(iwa)),3,27)
- end if
- if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then
- rmsshift = 1000.
- return
- end if
- end if
- rmsshift = rmsshift+shift**2
- if (lasttime .and. abs(shift).gt..0001) then
- if (mainnote) then
- if (.not.btest(nacc,29)) go to 10
- else
- if (.not.btest(icrdat(micrd(iwa)),29)) go to 10
- end if
-c
-c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there
-c was a manual shift but auto-shift was zero, will not come thru here, but shift value
-c will be left intact.
-c
- if (mainnote) then
- shift = shift+.05*(igetbits(nacc,7,10)-107)
- else
- shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107)
- end if
-10 continue
- if (twooftwo) then
-c
-c Record the shift for this accidental
-c
- if (shift .lt. -5.35) then
- call printl(' ')
- call printl('WARNING: auto-generated accidental '//
- * 'shift too big for PMX, ignoring')
- else
- ishift = nint(20*(shift+5.35))
- if (mainnote) then
- call setbits(nacc,7,10,ishift)
- else
- call setbits(icrdot(micrd(iwa)),7,20,ishift)
- end if
- end if
- else
-c
-c This is the earlier call to precrd, so need minimum shift
-c
- shiftmin = min(shiftmin,shift)
- end if
- end if
-c
-c Bail out if this is the last accidental to check
-c
- if (iwa .eq. naccid) go to 1
-c
-c Add this accidental to the right barrier! Count down from highest barrier segment,
-c find 1st one starting below top of accid, and first one starting below bot.
-c
- do 5 ibelowtop = nsegrb , 1 , -1
- if (segrb(2,ibelowtop) .lt.
- * nolev+segal(iacctype,2,nsegal(iacctype))) then
- do 9 ibelowbot = ibelowtop , 1 , -1
- if (segrb(2,ibelowbot) .lt.
- * nolev+segal(iacctype,2,1)) go to 6
-9 continue
- print*,'Oops2!'
- call stop1()
- end if
-5 continue
- print*,'Ugh0! in crdaccs'
- call stop1()
-6 continue
- netgain = nsegal(iacctype)-ibelowtop+ibelowbot
-c
-c Shift high segments up
-c
- if (netgain .ge. 0) then
- do 7 isegrb = nsegrb , ibelowtop+1 , -1
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-7 continue
-c
-c Set up 1st segment above accid
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- else
-c
-c netgain<0, must remove segments. Use same coding but reverse order,
-c work from bottom up
-c
- segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop)
- segrb(2,ibelowtop+netgain) =
- * nolev+segal(iacctype,2,nsegal(iacctype))
- ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop)
- do 12 isegrb = ibelowtop+1 , nsegrb
- segrb(1,isegrb+netgain) = segrb(1,isegrb)
- segrb(2,isegrb+netgain) = segrb(2,isegrb)
- ksegrb(isegrb+netgain) = ksegrb(isegrb)
-12 continue
- end if
-c
-c Insert new segments
-c
- do 8 isega = 1 , nsegal(iacctype)-1
- segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega)
- segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega)
- if (mainnote) then
- ksegrb(ibelowbot+isega) = 0
- else
- ksegrb(ibelowbot+isega) = micrd(iwa)
- end if
-8 continue
-c
-c Update number of barrier segments
-c
- nsegrb = nsegrb+netgain
-cc
-cc Temporary printout for boundary segments as built up
-cc
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa)
-cc
-1 continue ! next accidental
- if (lasttime .and. .not.twooftwo) then
-c
-c This is the final call on the pre-ask pass, so compute left-shift rqmt.
-c
- icashft = nint(-20*shiftmin)
- end if
-cc
-cc Temporary printout for boundary segments
-cc
-c if (twooftwo) then
-c write(15,'()')
-c write(15,'(a/(2f8.2,i5))')' y x kseg',
-c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb)
-c write(15,'(a/(2i5))')' micrd isetshft',
-c * (micrd(iwa),isetshft(iwa),iwa=1,naccid)
-c end if
-cc
- return
- end
- subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm,
- * levmaxacc,levminacc,icrdot0,twooftwo,icashft)
-c
-c nacc = accidental bitmap for main note
-c naccid = # of accid's in chord
-c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note
-c nolevm = level of main note
-c
-c This is called once per multi-accidental chord. In here, loop over all
-c permutations of the order of accidental as stored in kicrd. Each time thru
-c loop, call crdacc once, get rms shift. Only save permutation and rms value
-c if it is less than old value.
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
-c
-c Make consistent? 120106
-c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50)
- real*4 segrb0(2,50)
- logical btest,tagged,manual,lshift,twooftwo
-cc
-cc Temporary printout of level-rankings
-cc
-c write(15,'()')
-c do 98 iacc = 1 , naccid
-c if (kicrd(iacc) .eq. 0) then
-c write(15,'(3i5)')nolevm,icrdot0
-c else
-c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12),
-c * igetbits(icrdot(kicrd(iacc)),3,27)
-c end if
-c98 continue
-cc
-c
-c Initialize right-barrier
-c
- segrb0(1,1) = 0.
- segrb0(2,1) = -1000.
- segrb0(1,2) = 0.
- segrb0(2,2) = 1000.
- nsegrb0 = 2
- ksegrb0(1) = -1
- ksegrb0(2) = -1
-c
-c Search for left-shifted notes, Make up the initial right-barrier, which
-c will be good for all permutations.
-c irest()(27) is set if any notes are left-shifted
-c Must use ALL chord notes, not just ones w/ accid's.
-c
- if (btest(irest,27)) then
- do 15 icrd = icrd1-1, icrd2
- if (icrd .eq. icrd1-1) then
-c
-c Main note
-c
-c lshift = btest(ipl,8)
- lshift = btest(ipl,8) .or. btest(nacc,31)
- if (lshift) nolev = nolevm
- else
-c
-c Chord note
-c
- lshift = btest(icrdat(icrd),23)
-c if (lshift) nolev = igetbits(icrdat(icrd),7,12)
- if (lshift) then
- nolev = igetbits(icrdat(icrd),7,12)
- if (btest(nacc,31) .and. nolev.eq.nolevm+1) then
-c
-c This note is not really shifted, It is the upper of a 2nd with the main
-c note on an upstem, and Main note must be shifted.
-c nacc(31) signals the real truth.
-c
- lshift = .false.
- end if
- end if
- end if
- if (lshift) then
- do 16 isegrb = 1 , nsegrb0-1
- if (segrb0(2,isegrb+1) .gt. nolev-1) then
-c
-c Add this notehead to the right boundary here. Move all higher segs up 2.
-c
- do 17 iiseg = nsegrb0 , isegrb+1 , -1
- segrb0(1,iiseg+2) = segrb0(1,iiseg)
- segrb0(2,iiseg+2) = segrb0(2,iiseg)
- ksegrb0(iiseg+2) = ksegrb0(iiseg)
-17 continue
- go to 18
- end if
-16 continue
-18 continue
-c
-c Insert notehead into list. Set kseg=-2 to signal notehead shift.
-c
- iiseg = isegrb+1
- segrb0(1,iiseg) = -1.2
- segrb0(2,iiseg) = nolev-1.
- ksegrb0(iiseg) = -2
- segrb0(1,iiseg+1) = 0.
- segrb0(2,iiseg+1) = nolev+1.
- ksegrb0(iiseg+1) = -1
- nsegrb0 = nsegrb0+2
- end if
-15 continue
- end if
-c
-c Done setting right barrier for left-shifted noteheads
-c
- tagged = .false.
- manual = .false.
-c
-c Preprocess to check for manual shifts.
-c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then
-c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then
-c 1. Auto-shifting proceeds
-c 2. "A"-shifts add to autoshifts
-c 3. non-"A" shifts are ignored!
-c Else (>0 man shifts, none has "A")
-c No auto-ordering, No autoshifts, Observe all manual shifts.
-c End if
-c End if
-c
- maxmanshft = 0
- do 13 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
-c
-c Main note
-c
- manshft = igetbits(nacc,7,10)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(nacc,29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- else
-c
-c Chord note
-c
- manshft = igetbits(icrdot(kicrd(i)),7,20)
- if (manshft .ne. 0) then
- manual = .true.
- if (btest(icrdat(kicrd(i)),29)) then
- tagged = .true.
- else
-c maxmanshft = max(maxmanshft,64-manshft)
- maxmanshft = max(maxmanshft,107-manshft)
- end if
- end if
- end if
-13 continue
- if (manual) then
- if (tagged) then
-c
-c zero out all untagged shifts
-c
- do 14 i = 1 , naccid
- if (kicrd(i) .eq. 0) then
- if (.not.btest(nacc,29)) call setbits (nacc,7,10,0)
- else
- if (.not.btest(icrdat(kicrd(i)),29))
- * call setbits (icrdot(kicrd(i)),7,20,0)
- end if
-14 continue
- else
-c
-c There are manual shifts but none tagged. Only proceed if "Ao" was entered
-c
- if (.not.btest(nacc,28)) then
- icashft = maxmanshft
- return
- end if
- end if
- end if
- if (btest(nacc,28)) then
-c
-c Take the accidentals in order as originally input, then exit.
-c
- call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
-c end if
- else if (naccid .eq. 3) then
-c
-c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd
-c then place in order top, bottom, middle.
-c
- do 20 i = 1 , 3
- if (kicrd(i) .eq. 0) then
- irank = icrdot0
- nolev = nolevm
- else
- irank = igetbits(icrdot(kicrd(i)),3,27)
- nolev = igetbits(icrdat(kicrd(i)),7,12)
- end if
- if (irank .eq. 1 ) then
- micrd(1) = kicrd(i)
- else
- micrd(5-irank) = kicrd(i)
- end if
- if (irank .eq. 2) then
- levmidacc = nolev
- end if
-20 continue
- if (levmaxacc.ne.levmidacc+1 .and.
- * levmidacc.ne.levminacc+1) then
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end if
- end if
- rmsmin = 100000.
-c
-c Initialize permutation array
-c
- do 7 i = 1 , naccid
- iperm(i) = i
-7 continue
-c
-c Start looping over permutations
-c
- do 8 ip = 1 , 5041
- if (ip .ne. 1) then
-c
-c Work the magic algorithm to get the next permutation
-c
- do 1 k = naccid-1 , 1 , -1
- if (iperm(k) .le. iperm(k+1)) go to 2
-1 continue
-c
-c If here, we just got the last permutation, so exit the loop over permutations
-c
- go to 10
-2 continue
- do 3 j = naccid , 1 , -1
- if (iperm(k) .le. iperm(j)) go to 4
-3 continue
-4 continue
- it = iperm(j)
- iperm(j) = iperm(k)
- iperm(k) = it
- is = k+1
- do 5 ir = naccid , 1 , -1
- if (ir .le. is) go to 6
- it = iperm(ir)
- iperm(ir) = iperm(is)
- iperm(is) = it
- is = is+1
-5 continue
-6 continue
- end if
-c
-c New we have a permutation. Take icrd values out of kicrd and put them into
-c micrd in the order of the permutation
-c
- do 9 i = 1 , naccid
- micrd(i) = kicrd(iperm(i))
-9 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false.,
- * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
-cc
-cc Temporary printout
-cc
-c write(15,*)'perm done, rmsshift:',rmsshift
-cc
- if (rmsshift .lt. rmsmin) then
-c
-c Save this permutation, reset minrms
-c
- do 11 i = 1 , naccid
- ipermsav(i) = iperm(i)
- rmsmin = rmsshift
-11 continue
- end if
-8 continue
- print*,'Should not BEEEEEE here!'
- call stop1()
-10 continue
-c
-c Done looping, get info for the final choice
-c
- do 12 i = 1 , naccid
- micrd(i) = kicrd(ipermsav(i))
-12 continue
-cc
-cc Temporary printout
-cc
-c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid)
-cc
- call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true.,
- * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft)
- return
- end
- subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut)
- character*1 sq,chax
- character*3 acsymq
- character*8 noteq
- character*79 notexq
- logical btest,caut
- sq = chax(92)
- if (ihshft .eq. -107) ihshft=0
-cc
-cc If main note shifted left, so shift accid. Terminate below, when acc. is done.
-cc
- if (ihshft .ne. 0) then
-c
-c Accid must be shifted horizontally
-c
- if (ihshft .lt. 0) then
- notexq = sq//'loffset{'
- ihshft = -ihshft
- else
- notexq = sq//'roffset{'
- end if
- hshft = .05*ihshft
- if (hshft .lt. 1.) then
- write(notexq(10:12),'(f3.2)')hshft
- lnote = 12
- else
- write(notexq(10:13),'(f4.2)')hshft
- lnote = 13
- end if
- notexq = notexq(1:lnote)//'}{'//sq
- lnote = lnote+3
- else
- notexq = sq
- lnote = 1
- end if
- if (btest(nacc,3)) then
- notexq = notexq(1:lnote)//'big'
- lnote = lnote+3
- end if
- if (caut) then
-c
-c Cautionary accidental. Need to define bigcna,... in pmx.tex
-c
- notexq = notexq(1:lnote)//'c'
- lnote = lnote+1
- end if
- call accsym(nacc,acsymq,lacc)
- notexq = notexq(1:lnote)//acsymq(1:lacc)
- lnote = lnote+lacc
- noleva = nolev
- if (ivshft .ne. 0) noleva = noleva+ivshft-32
- call notefq(noteq,lnoten,noleva,ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihshft .ne. 0) then
-c
-c Terminate horizontal shift
-c
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt,
- * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen,
- * dotxtup,nacc)
- parameter (nm=24,mv=24576)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical lowdot,dotxtup
- integer*4 ihornb(nm,24),nornb(nm)
- character*1 ulq(nm,9),chax
- character*7 nosymq
- character*8 noteq
- character*79 notexq,outq
- character*80 soutq
- logical btest,isleft,isright,beamon
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
-c
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c
-c This subr. once produced notexq for entire chord. 10/18/97 altered to write
-c chord notes as we go. 10/22/97 find range of icrd first.
-c 2/25/98 moved rangefinding to precrd so done before slurs, so now
-c on entry, icrd1, icrd2 define range of icrd for this chord.
-c
-c Set counter (for this note) for chord notes present. Set notmain=T.
-c Will test for notmain=.true. in addmidi to tell whether to save pitch.
-c
- nmidcrd = 0
- notmain = .true.
- crdacc = .false.
- do 5 icrd = icrd1 , icrd2
- lnote = 0
- nolev = igetbits(icrdat(icrd),7,12)
-c
-c 3/8/03 save original pitch to use in midi, in case 2nds alter things.
-c
- nolevo = nolev
-c
-c Check for special situations with 2nds (see precrd).
-c
- if (btest(nacc,30)) then
- if (nolev .eq. nolevm-1) nolev = nolevm
- else if (btest(nacc,31)) then
- if (nolev .eq. nolevm+1) nolev = nolevm
- end if
-c
-c Lower dot for lower-voice notes?. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest (cannot be a rest in a chord!)
-c. 5. Flag (lowdot) is set to true
-c
- if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then
- if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then
- if (btest(icrdat(icrd),26)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- call setbits(icrdot(icrd),7,0,
- * igetbits(icrdot(icrd),7,0)-20)
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3))
- end if
- end if
- end if
- if (btest(icrdat(icrd),26)) then
-c
-c Move the dot.
-c
- updotc = 0.1*(iand(127,icrdot(icrd))-64)
- rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
- call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3))
- end if
- isleft = btest(icrdat(icrd),23)
- isright = btest(icrdat(icrd),24)
-c
-c Check for ornament in chord.
-c
- if (icrdorn(icrd) .gt. 0) then
- call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
- * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
- * ip,0,beamon,.true.)
-c
-c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
-c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt,
-c * notcrd,beamon,iscrd)
-c
- call addstr(outq,lout,soutq,lsout)
- end if
-c
-c Chord-note symbol. First check for breve
-c
- if (nodu .eq. 128) then
- nosymq = chax(92)//'zbreve'
- lsym = 7
- else
-c
-c Not a breve chord. Get first letters in chord-note symbol
-c
- if (isleft) then
- nosymq = chax(92)//'l'
- else if (isright) then
- nosymq = chax(92)//'r'
- else
- nosymq = chax(92)//'z'
- end if
- if (nodu .ge. 64) then
- nosymq = nosymq(1:2)//'w'
- else if (nodu .ge. 32) then
- nosymq = nosymq(1:2)//'h'
- else
- nosymq = nosymq(1:2)//'q'
- end if
- if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then
- lsym = 3
- else if (.not.btest(islur,3) .or. dotxtup) then
-c
-c Single dot
-c
- nosymq = nosymq(1:3)//'p'
- lsym = 4
- else
-c
-c Double dot
-c
- nosymq = nosymq(1:3)//'pp'
- lsym = 5
- end if
- end if
- if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then
-c
-c Accidental and not MIDI-only. Build up bits 0-3 of nacc
-c
- nactmp = igetbits(icrdat(icrd),3,20)
-c
-c Kluge for bigness. Only means 'As' has not been issued
-c
- if (bacfac .ne. 1.e6) nactmp = nactmp+8
- call doacc(igetbits(icrdot(icrd),7,20)-107,
- * igetbits(icrdot(icrd),6,14),
-c * notexq,lnote,nactmp,nolev,ncmid(iv,ip))
-c Get original nolev, not altered to deal with 2nds
- * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12),
-c * ncmid(iv,ip))
- * ncmid(iv,ip),btest(icrdat(icrd),31))
- notexq = notexq(1:lnote)//nosymq
- crdacc = .true.
- else
- notexq = nosymq
- end if
- lnote = lnote+lsym
-c
-c Get note name (again if accid, due to possible octave jump)
-c
- call notefq(noteq,lnoten,nolev,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
-c
-c Put in note name
-c
- notexq = notexq(1:lnote)//noteq
- lnote = lnote+lnoten
- if (btest(icrdat(icrd),25)) then
-c
-c Arpeggio signal
-c
-c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout)
- call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout)
- end if
- call addstr(notexq,lnote,soutq,lsout)
- if (ismidi) then
-c
-c Here is where we collect MIDI pitch info for the chord note. By checking
-c notmain, addmidi(...) knows to just compute the
-c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi()
-c for MAIN note, will put in note codes for all chord notes + main note.
-c
- kv = 1
- if (ivx .gt. iv) kv=2
- nmidcrd = nmidcrd+1
- if (nmidcrd .gt. 20) then
- print*
- print*,'21 chord notes is too many for midi processor'
- call stop1()
- end if
-c
-c Use original saved pitch level, unaltered by 2nds logic.
-c
-c call addmidi(midchan(iv,kv),nolevo,
- call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)),
- * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.)
- end if
-5 continue
- notmain = .false.
- return
- end
- subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv,
- * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout)
- parameter (nm=24)
-c
-c Inputs are array *elements* except ihornb,nornb,ulq
-c
- common /commus/ musize,whead20
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,beamon,upstem,nostem
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 udqq,chax,ulq(nm,9)
- character*4 dynstrq
- character*5 numpq
- character*48 dyntablq,tempq
- character*79 notexq
- character*80 soutq
- integer*4 ihornb(nm,24),nornb(nm),idynn(10)
- data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/
- numdyn = 0
-c
-c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values
-c in idynn(1...4)
-c
- do 1 idyn = 1 , ndyn
-c ivxtent = iand(idyndat(idyn),15)
- ivxtent = iand(idyndat(idyn),15)
- * +16*igetbits(idynda2(idyn),1,10)
- if (ivxtent .eq. ivx) then
- iptent = igetbits(idyndat(idyn),8,4)
- if (iptent .eq. ip) then
- numdyn = numdyn+1
- idynn(numdyn) = idyn
- else if (iptent .gt. ip) then
-c
-c I don't think there are any more possible for this ivx,ip, so exit loop
-c
- go to 2
- end if
-c else if (ivxtent .gt. ivx) then
-c go to 2
- end if
-1 continue
-2 continue
-c
-c At this point there is a list of idyn's in idynn(1...numdyn)
-c Compute level, and stem-dir'n-based horizontal tweaks
-c
- hoffsd = 0.
-c
-c Set upstem to false as default
-c
- upstem = .false.
- if (btest(irest,0)) then
-c
-c It's a rest. Assume it doesn't go below the staff
-c
- lbot = ncm-4
- else if (.not.beamon) then
- if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-7,ncm-4)
- else
- lbot = min(minlev-7,ncm-4)
- end if
- end if
- else
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- upstem = .true.
- if (.not.btest(ipl,10)) then
- lbot = min(nolev-1,ncm-4)
- else
- lbot = min(minlev-1,ncm-4)
- end if
- else
- hoffsd = -.5
- lbot = ihornb(ivx,nornb(ivx))+1
- if (lbot .eq. 1) then
-c
-c Kluge for non-beamed, down xtup, for which ihorb was never set.
-c Assumes stem is shortened.
-c
- lbot = nolev-5
- end if
- nornb(ivx) = nornb(ivx)+1
- end if
- end if
- lbot = lbot-5
- jtxtdyn1 = 1
-c
-c Now ready to loop over current dyn's
-c
- do 3 icntdyn = 1 , numdyn
- idynd = idyndat(idynn(icntdyn))
- idynd2 = idynda2(idynn(icntdyn))
- idno = igetbits(idynd,4,12)
-c ivx = iand(15,idynd)
- ivx = iand(15,idynd)+16*igetbits(idynd2,1,10)
-c
-c Build the command into notex in stages. Insert name & rq'd args in order:
-c
-c Command name
-c hpstrt, hpcend, hpdend, pmxdyn
-c ivx
-c X X X
-c level
-c X X X
-c hoff
-c X X X X
-c d-mark
-c X
-c
- if (idno .eq. 0) then
-c
-c Text-dynamic
-c
- notexq = chax(92)//'txtdyn'
- lnote = 7
- else if (idno .le. 12) then
-c
-c Letter-group
-c
- notexq = chax(92)//'pmxdyn'
- lnote = 7
- else if (fontslur) then
- lnote = 7
- if (idno .eq. 13) then
-c
-c Start a hairpin
-c
- notexq = chax(92)//'hpstrt'
- else if (idno .eq. 14) then
-c
-c End crescendo
-c
- notexq = chax(92)//'hpcend'
- else
-c
-c End decrescendo
-c
- notexq = chax(92)//'hpdend'
- end if
- else
-c
-c Postscript hairpins
-c
- lnote = 7
- if (idno .eq. 13) then
- notexq = chax(92)//'Icresc'
- else if (idno .eq.14) then
- notexq = chax(92)//'Idecresc'
- lnote = 9
- else
- notexq = chax(92)//'Tcresc'
- end if
- end if
- if (idno .ge. 13) then
-c
-c Put in voice number
-c
- if (ivx .le. 9) then
- notexq = notexq(1:lnote)//char(48+ivx)
- lnote = lnote+1
- else if (ivx .le. 19) then
- notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}'
- lnote = lnote+4
- end if
- end if
-c
-c Begin setting level
-c
- lbot1 = lbot
- if (idno.gt.0 .and. idno.le.5) then
-c
-c All letters are short so raise a bit.
-c
- lbot1 = lbot1+1
- else if (idno .ge. 13) then
- lbot1 = lbot1+2
- end if
-c
-c Convert so reference is bottom line
-c
- lbot1 = lbot1-ncm+4
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start. Save level and user-tweak before applying user tweak.
-c
- levdsav(ivx) = lbot1
- levhssav(ivx) = 0
- if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17)
- else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then
-c
-c Hairpin end; Compare level with saved start level before user-tweaks
-c
- lbot1 = min(lbot1,levdsav(ivx))
-c
-c Save pre-tweak level
-c
- lpretweak = lbot1
- end if
-c
-c Check for user-defined vertical tweak
-c
- if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17)
-c
-c Now horizontal stuff
-c
- hoff = hoffsd
-c
-c Some special horizontal tweaks
-c
- if (upstem .and. idno.gt.0 .and.
- * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4
-c
-c User-defined tweaks
-c
- if (btest(idynd2,0))
- * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1
- if (numdyn .gt. 1) then
-c
-c Horizontal-interaction-based tweaks.
-c
-c Cases:
-c numdyn type1 type2 type3 data used
-c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12)
-c 2 hrpnend wrd-grp - ivowg,hoh2
-c 2 hrpnend hrpnstrt - hoh2h1(1...2)
-c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1
-c
- if (idno.gt.0 .and. idno.le.12) then
-c
-c Word-group, may need vertical tweak to line up.
-c
- lbot1 = lbot1+ivowg(idno)
-c
-c Protecting against hp start-stop on same note
-c
- else if (((fontslur.and.idno.ge.14).or.idno.eq.15)
- * .and. icntdyn.lt.numdyn) then
-c
-c Hairpin ending, check next type
-c
- if ((fontslur .and.
- * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or. (.not.fontslur .and.
- * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13)
- * .or.
- * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14))))
- * then
-c
-c Hairpin end then hairpin start, no words, (remember dealing with end now)
-c
- hoff = hoff+hoh2h1(1)
- else
-c
-c Hairpin end then word-group, need idno for w-g to set hp offset
-c
- hoff = hoff +
- * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12))
- end if
-c
-c Protecting against hp start-stop on same note
-c
- else if (icntdyn.gt.1 .and. idno.gt.0 .and.
- * ((fontslur.and.idno.lt.14).or.
- * (.not.fontslur.and.idno.lt.15))) then
-c
-c Hairpin start, check prior type
-c
- if ((fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14)
- * .or.
- * (.not.fontslur.and.
- * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15))
- * then
-c
-c Hairpin end then hairpin start, (remember dealing with start now)
-c
- hoff = hoff+hoh2h1(2)
- else
-c
-c Hairpin start after word-group, need idno for w-g to set hp offset
-c
- hoff = hoff+
- * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12))
- end if
- end if
- end if
-c
-c End of if-block for 2- or 3-way interactions.
-c
- if ((.not.fontslur) .and. idno.ge.13)
-c
-c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width
-c
- * hoff = (hoff+.5)*6./2.5
-c
-c Position corrections all done now. Put in the level.
-c
- if ((fontslur.and.idno.eq.13) .or.
- * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then
-c
-c Hairpin start.
-c
- if (.not.fontslur) then
-c
-c Postscript hairpin start...inset placeholder for start level.
-
- notexq = notexq(1:lnote)//'{ }'
- lnote = lnote+5
- end if
- else
-c
-c Insert actual level in all cases except hairpin start
-c Create string with level in it
-c
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Level has now been computed and stored in numpq
-c Append the level
-c
- notexq = notexq(1:lnote)//numpq(1:lnumpq)
- lnote = lnote+lnumpq
- end if
- if (abs(hoff) .lt. .001) then
-c
-c No horiz offset
-c
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
-c
-c Horizontal tweak
-c
- lform = lfmt1(hoff)
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')hoff
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- if (idno .eq. 0) then
-c
-c text-dynamic. Find the string and append it
-c
- do 4 jtxtdyn = jtxtdyn1 , ntxtdyn
-c ivxip = ivx+16*ip
- ivxip = ivx+32*ip
- if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5
-4 continue
- call printl('Abnormal stop in putdyn')
- call stop1()
-5 continue
- ltxtdyn = lenstr(txtdynq(jtxtdyn),128)
-c
-c Font size based on musicsize
-c
- if (musize .eq. 20) then
- notexq = notexq(1:lnote)//'{'//char(92)//'medtype'
- * //char(92)//'it '
- lnote = lnote+13
- else if (musize .eq. 16) then
- notexq = notexq(1:lnote)//'{'//char(92)//'normtype'
- * //char(92)//'it '
- lnote = lnote+14
- else if (musize .eq. 24) then
- notexq = notexq(1:lnote)//'{'//char(92)//'bigtype'
- * //char(92)//'it '
- lnote = lnote+13
- else if (musize .eq. 29) then
- notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype'
- * //char(92)//'it '
- lnote = lnote+13
- end if
- notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn)
- * //'}'
- lnote = lnote+ltxtdyn+1
-c
-c Reset jtxtdyn1 just in case >1 txtdyn on same note.
-c
- jtxtdyn1 = jtxtdyn+1
- else if (idno .le. 12) then
-c
-c Letter-group dynamic. Append the letter-group command
-c
- id = 4*idno
- dynstrq = dyntablq(id-3:id)
- id = lenstr(dynstrq,4)
- notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id)
- lnote = lnote+1+id
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- if ((.not.fontslur).and.idno.eq.15) then
-c
-c PS slurs on, hairpin is ending. Go back and set height at beginning.
-c Add user-defined tweak to default level
-c
- lbot1 = lpretweak+levhssav(ivx)
- if (lbot1 .gt. 9) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else if (lbot1 .gt. -1) then
- numpq = char(48+lbot1)
- lnumpq = 1
- else if (lbot1 .gt. -10) then
- numpq = '{'
- write(numpq(2:3),'(i2)')lbot1
- numpq = numpq(1:3)//'}'
- lnumpq = 4
- else
- numpq = '{'
- write(numpq(2:4),'(i3)')lbot1
- numpq = numpq(1:4)//'}'
- lnumpq = 5
- end if
-c
-c Construct string to search backwards for placeholder
-c
- if (ivx .le. 9) then
- tempq = 'cresc'//char(48+ivx)//'{ }'
- ltemp = 11
- else if (ivx .le. 19) then
- tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }'
- ltemp = 14
- else
- tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }'
- ltemp = 14
- end if
- write(11,'(a)')soutq(1:lsout)//'%'
- lsout = 0
- call backfill(11,tempq,ltemp,
- * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq)
- end if
-3 continue
-c
-c Shrink arrays, decrease ndyn 111109
-c
- do 6 icntdyn = numdyn, 1 , -1
- do 7 jdyn = idynn(icntdyn) , ndyn-1
- idyndat(jdyn) = idyndat(jdyn+1)
- idynda2(jdyn) = idynda2(jdyn+1)
-7 continue
- ndyn = ndyn-1
-6 continue
- end
- subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl,
- * farend,
- * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq)
-c
-c ip will be one LESS than current note, for way-after's before bar-end,
-c It is only used to find ig.
-c ig is returned to makeabar in case there's a slur that needs to be ended
-c
- parameter (nm=24)
- logical beamon,stemup
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
- * normsp,farend,fontslur,WrotePsslurDefaults
- real*4 ptgr(37)
- character*80 soutq
- character*128 litq
- character*79 notexq
- character*20 voltxtq
- character*10 figq
- character*8 noteq,noteqGA
- character*3 acsymq
- character*1 sq,chax,udqq,ulq(nm,9)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- sq = chax(92)
- isgaft = btest(ipl,29)
- iswaft = btest(ipl,31)
- normsp = .not. isgaft
-c
-c Find ig.
-c
- do 120 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121
-120 continue
- print*,'Problem finding grace index in dograce'
- stop
-121 continue
- ngs = ngstrt(ig)
- mg = multg(ig)
- wheadpt1 = wheadpt*fullsize(ivx)
-c
-c For way-after-graces at end of bar, must set the octave.
-c
- if (farend) then
- noctup = 0
- if (ncm .eq.23) noctup = -2
- end if
- if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then
- if (listslur .eq. 16777215) then
- print*
- print*,'You defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Slur on fore-grace. Get index of next slur not in use, from 23 down.
-c
- ndxslur = log2(16777215-listslur)
-
- end if
- if (nng(ig) .eq. 1) then
-c
-c Single grace.
-c
- if (normsp) then
-c
-c Anything but GA
-c
- call addstr(sq//'shlft',6,soutq,lsout)
- niptgr = nint(ptgr(ig))
-c
-c Empirical tweak for postscript.
-c
-C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3)
-c++
- if (niptgr .lt. 10) then
- call addstr(chax(48+niptgr)//'{',2,soutq,lsout)
- else if (niptgr .lt. 100) then
- write(notexq(1:2),'(i2)')niptgr
- call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout)
- else
- print*,
- * 'Call Dr. Don if you really want grace note group > 99 pt'
- stop
- end if
- else
- call addstr(sq//'gaft{1.5}{',11,soutq,lsout)
-c
-c GA. Compute aftshft, for later use.
-c
- aftshft = grafac
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac
- aftshft = aftshft*wheadpt
- end if
- if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then
-c
-c Start slur on pre-grace. No accounting needed since will be ended very soon.
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Start Postscript slur.
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print slur number, 23-ndxslur
-c
- lnote = 0
- if (23-ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = chax(71-ndxslur)
- lnote = 1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = '{1'//chax(61-ndxslur)//'}'
- lnote = 4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = 4
- end if
-c if (11-ndxslur .lt. 10) then
-c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten,
-c * soutq,lsout)
-c else
-c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
-c * 4+lnoten,soutq,lsout)
-c end if
- call addstr(notexq(1:lnote)//noteq(1:lnoten),
- * lnote+lnoten,soutq,lsout)
- if (.not.fontslur) then
-c
-c Horizontal tweaks for postscript slur on single grace
-c
- stemup = .true.
- if (upg(ig)) then
-c
-c Check for up-grace + down stem. Get stem direction
-c
- if (.not.beamon) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev,ncmidx,
- * islur,nvmx,ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or. tnote.gt.63
- end if
- if (stemup) then
- call addstr('{-.3}',5,soutq,lsout)
- else
- call addstr('{-.8}',5,soutq,lsout)
- end if
- end if
- end if
- if (naccg(ngs) .gt. 0) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
-c Save for checking octave shifts in GA
-c
- if (isgaft) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)//
- * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
- if (slashg(ig)) then
- notexq = sq//'grc'
- lnote = 4
- else if (mg .eq. 0) then
- notexq = sq//'zq'
- lnote = 3
- else
- notexq = sq//'zc'
- do 61 i = 2 , mg
- notexq = notexq(1:i+1)//'c'
-61 continue
- lnote = mg+2
- end if
- if (upg(ig)) then
- notexq = notexq(1:lnote)//'u'
- else
- notexq = notexq(1:lnote)//'l'
- end if
- call addstr(notexq,lnote+1,soutq,lsout)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
-c
- if (isgaft .and. naccg(ngs).eq.0) then
- lnotenGA = lnoten
- noteqGA = noteq
- end if
-c
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call addstr(noteq,lnoten,soutq,lsout)
- if (slashg(ig)) call addstr(sq//'off{-'//sq//
- * 'noteskip}',16,soutq,lsout)
-c
-c Above code needed since slashg causes spacing
-c
- if (slurg(ig) .and. (iswaft.or.isgaft)) then
-c
-c Terminate slur on single after-grace
-c
-c ndxslur = igetbits(ipl,4,23)
- ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-cc Print 11-ndxslur
-c Print 24-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c call addstr(chax(59-ndxslur)//noteq(1:lnoten),
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
-c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten),
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
- slurg(ig) = .false.
- listslur = ibclr(listslur,ndxslur)
- end if
- call addstr('}',1,soutq,lsout)
-c
-c+++ Try to fix loss of octave with single gaft
-c
-c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}',
-c * 13+lnoten,soutq,lsout)
- if (isgaft) then
- itrans = 0
- do 1 i = 1 , lnotenGA
- if (noteqGA(i:i) .eq. chax(39)) then
- itrans = itrans+7
- else if (noteqGA(i:i) .eq. chax(96)) then
- itrans = itrans-7
- end if
-1 continue
- if (itrans. eq. -14) then
- call addstr(sq//'advance'//sq//'transpose-14',21,
- * soutq,lsout)
- else if (itrans .eq. -7) then
- call addstr(sq//'advance'//sq//'transpose-7',20,
- * soutq,lsout)
- else if (itrans .eq. 7) then
- call addstr(sq//'advance'//sq//'transpose7',19,
- * soutq,lsout)
- else if (itrans .eq. 14) then
- call addstr(sq//'advance'//sq//'transpose14',20,
- * soutq,lsout)
- end if
- end if
- else
-c
-c Multiple grace. Put in literally. Compute beam stuff
-c
- sumx = 0.
- sumy = 0.
- sumxy = 0.
- sumxx = 0.
- sumyy = 0.
- x = 0.
- do 118 ing = ngs , ngs+nng(ig)-1
- if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac
- y = nolevg(ing)
- sumx = sumx + x
- sumy = sumy + y
- sumxy = sumxy + x*y
- sumxx = sumxx + x*x
- sumyy = sumyy + y*y
- x = x+emgfac
-118 continue
- delta = nng(ig)*sumxx-sumx*sumx
- em = (nng(ig)*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*gslfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/gslfac*sumx)/nng(ig)
- nolev1 = nint(beta)
-c
-c Back up
-c
- notexq = sq//'settiny'//sq//'off{'
- if (normsp) then
- write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig)
- call addstr(notexq(1:18)//'pt}',21,soutq,lsout)
- finalshift = ptgr(ig)
- else
- aftshft = wheadpt*1.33
- if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5
- write(notexq(14:17),'(f4.1)')aftshft
- call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout)
- end if
-c
-c Start the beam
-c
- notexq = sq//'ib'
- do 119 ing = 2 , mg
- notexq = notexq(1:ing+1)//'b'
-119 continue
- if (upg(ig)) then
- notexq = notexq(1:mg+2)//'u'
- else
- notexq = notexq(1:mg+2)//'l'
- end if
- notexq = notexq(1:mg+3)//'0'
-c
-c Get starting note for beam
-c
- call notefq(noteq,lnoten,nolev1,ncm)
- call addstr(notexq(1:mg+4)//noteq(1:lnoten),
- * mg+4+lnoten,soutq,lsout)
-c
-c Put in the slope
-c
- if (islope .ge. 0) then
- call addstr(chax(48+islope),1,soutq,lsout)
- else
- call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout)
- end if
-c
-c Start a slur on multiple fore-grace
-c
- if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (fontslur) then
- if (upg(ig)) then
- call addstr(sq//'islurd',7,soutq,lsout)
- else
- call addstr(sq//'isluru',7,soutq,lsout)
- end if
- else
-c
-c Need a tweak for postscript slur
-c
- if (upg(ig)) then
- call addstr(sq//'isd',4,soutq,lsout)
- else
- call addstr(sq//'isu',4,soutq,lsout)
- end if
- end if
-c
-c Print 11-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten,
- * soutq,lsout)
- else if (23-ndxslur .lt. 2) then
- call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten),
- * 4+lnoten,soutq,lsout)
- end if
-c
-c Put in tweak for postscript slur
-c
- if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout)
- end if
-c
-c Put in first note. Call notefq again in case octave changed
-c
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- if (naccg(ngs) .eq. 0) then
- notexq = sq//'zqb0'//noteq(1:lnoten)
- lnote = 5+lnoten
- else
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ngs),acsymq,lacc)
- notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten)
- lnote = 4+lacc+lnoten
- call notefq(noteq,lnoten,nolevg(ngs),ncm)
- notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten)
- lnote = lnote+5+lnoten
- end if
- call addstr(notexq,lnote,soutq,lsout)
- do 127 ing = ngs+1 , ngs+nng(ig)-1
-c
-c Skip
-c
- ptoff = wheadpt1*emgfac
- if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac
- if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
- notexq = sq//'off{'
- write(notexq(6:8),'(f3.1)')ptoff
- if (normsp) finalshift = finalshift-ptoff
- call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
- if (ing .eq. ngs+nng(ig)-1) then
-c
-c Terminate beam if needed
-c
- if (upg(ig)) then
- call addstr(sq//'tbu0',5,soutq,lsout)
- else
- call addstr(sq//'tbl0',5,soutq,lsout)
- end if
-c
-c Terminate after slur if needed
-c
- if ((isgaft.or.iswaft) .and. slurg(ig)) then
-c if (iswaft) ndxslur = igetbits(ipl,4,23)
- if (iswaft) ndxslur = igetbits(ipl,5,23)
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'tslur',6,soutq,lsout)
-c
-c Print 11-ndxslur
-cc Print 23-ndxslur
-c
- if (23-ndxslur .lt. 10) then
- call addstr(chax(71-ndxslur)//noteq(1:lnoten),
- * 1+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- call addstr('{2'//chax(61-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- else
- call addstr('{1'//chax(51-ndxslur)//'}'
- * //noteq(1:lnoten),4+lnoten,soutq,lsout)
- end if
-c
-c Stop slur terminator after exit from this subroutine
-c
- listslur = ibclr(listslur,ndxslur)
- slurg(ig) = .false.
- end if
- end if
-c
-c Accidental if needed
-c
- if (naccg(ing).gt.0) then
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- call accsym(naccg(ing),acsymq,lacc)
- call addstr(sq//'big'//acsymq(1:lacc)
- * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
- end if
-c
-c Put in the (beamed) grace note
-c
- call notefq(noteq,lnoten,nolevg(ing),ncm)
- call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten,
- * soutq,lsout)
-127 continue
-c
-c Terminate the grace
-c
-c notexq = sq//'normalnotesize'//sq//'off{'
-c lnote = 20
-c notexq = '}'//sq//'off{'
-c lnote = 6
- notexq = sq//'off{'
- lnote = 5
- ptoff = wheadpt*emgfac
- if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17))
- * ptoff = ptoff+wheadpt*accfac
- if (isgaft .and. .not.iswaft) then
- notexq = notexq(1:5)//'-'
- lnote = 6
- ptoff = aftshft
- end if
- if (normsp) ptoff = finalshift
- if (ptoff .lt. 9.95) then
- write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
- lnote = lnote+3
- else if (ptoff .lt. 99.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff
- lnote = lnote+5
- end if
- call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
- if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
- call addstr(sq//'resetsize',10,soutq,lsout)
- end if
- return
- end
- subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip,
- * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur,
- * ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note.
-c 12 May 2002 Create this subroutine to isolate postscript slurs/ties.
-c Always set \Nosluradjust\Notieadjust
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,
- * settie,fontslur,pstie,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term.
-c 18 int(ndxslur/16), ditto. So this allows ndxslur>15.
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-c
-c Bits in isdat4 Only used for linebreak slurs
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-13.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
- * kv .eq. igetbits(isdata,1,12)+1) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- pstie = btest(isdat2(isdat),3) .or. idcode.eq.1
- if (btest(isdata,11)) then
-c
-c Turnon
-c
-c if (nolevs.eq.0 .or. nolevs.gt.60) then
-cc
-cc Note was a rest, cannot start slur on rest.
-cc
-c print*
-c call printl('Cannot start slur on a rest')
-c call stop1()
-c nolevs = ncm+5
-c end if
-c
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
-c
-c Set level for slur starting on rest
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
- if (slurudq .eq. 'u') then
- nolevs = ncm+2
- else
- nolevs = ncm-2
- end if
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twentyfifth slur, one too many!'
- write(15,'(/,a)')
- * 'You defined the twentyfifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from 12 down
-c
- ndxslur = log2(16777215-listslur)
-c write(*,'()')
-c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c write(*,'(10x,B24)')listslur
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff+8
- else
- ihoff = ihoff+2
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- notexq = chax(92)
- lnote = 1
-c
-c Check for local adjustment default changes
-c
- if (btest(isdat2(isdat),26)) then
- notexq = chax(92)//'sluradjust'//chax(92)
- lnote = 12
- else if (btest(isdat2(isdat),27)) then
- notexq = chax(92)//'nosluradjust'//chax(92)
- lnote = 14
- else if (btest(isdat2(isdat),28)) then
- notexq = chax(92)//'tieadjust'//chax(92)
- lnote = 11
- else if (btest(isdat2(isdat),29)) then
- notexq = chax(92)//'notieadjust'//chax(92)
- lnote = 13
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = notexq(1:lnote)//'islur'//slurudq
- lnote = lnote+6
- else
- notexq = notexq(1:lnote)//'is'//slurudq
- lnote = lnote+3
- end if
-c
-c Prepend postscript tie switch
-c
- if (pstie) then
- notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote)
- lnote = lnote+10
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
-c noteq = notexq
-c notexq = chax(92)//'dotted'//noteq
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
-c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- islhgt = nolevs+iupdn+ivoff
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Store height and staff mid level for use with LineBreakTies
-c
- call setbits(isdat3(isdat),8,14,islhgt)
- call setbits(isdat3(isdat),8,22,ncm)
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
-c levson(midchan(iv,kv)) = nolev
- levson(midchan(iv,kv)) = nolevs
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
- * kv.eq.igetbits(isdat1(j),1,12)+1) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
-c
-c Bugfix 070901 for slur ending on rest in 2-voice staff
-c
-c if (nolevs.eq.0 .or. nolevs.gt.60) then
- if (nolevs.le.2 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then
-c
-c Deal with \curve or \midslur. isdat is ending, j is start.
-c
- if (btest(isdat3(isdat),0)) then
- imid = igetbits(isdat3(isdat),6,2)-32
- else
- imid = igetbits(isdat3(j),6,2)-32
- end if
-c
-c Postscript slurs, and \midslur adjustment is needed. Invoke macro
-c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 2-3 default
-c 4 h
-c 5 H
-c 6+ HH
-c
- call addstr(chax(92)//'psforts'//
- * chax(48+min(abs(imid),6)),9,soutq,lsout)
- end if
-c
-c Shift slur ending for stem on any note?
-c
- if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then
- if (.not.pstie) then
- ihoff = ihoff-8
- else
- ihoff = ihoff-3
- end if
- end if
- if (iscrd) then
-c
-c Shift termination for shifted notehead?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c
-c Switch to postscript tie
-c
- if (pstie) then
- notexq = chax(92)//'tieforts'//notexq(1:lnote)
- lnote = lnote+9
- end if
-c
-c Print 13-ndxslur
-c 5/25/08 Allow 14 slurs
-c
- if (23-ndxslur .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- end if
- ivoff = ivoff+ivoffinc
- end if
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
- if (idcode .eq. is2n1) is1n1=0
- end if
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (ihoff .ne. 0) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),
- * '(f'//chax(48+lform)//'.1)')shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Clear the bit from list of slurs in use
-c
- listslur = ibclr(listslur,ndxslur)
-c
-c Zero out the entire strings for start and stop
-c
- isdata = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(j) = 0
- isdat4(j) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then
- icm = midchan(iv,kv)
- if (slmon(icm)) then
- if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then
-c
-c There is a tie here. NB!!! assumed no accidental on 2nd member of tie.
-c
- levsoff(icm) = nolevs
- settie = .true.
- else
- levsoff(icm) = 0
- levson(icm) = 0
- slmon(icm) = .false.
- end if
- end if
- end if
- end if
- isdat1(isdat) = isdata
- end if
-1 continue
-c
-c Clear and collapse the slur data list
-c
- numdrop = 0
- do 2 isdat = 1 , nsdat
- if (isdat1(isdat) .eq. 0) then
- numdrop = numdrop+1
- else if (numdrop .gt. 0) then
- isdat1(isdat-numdrop) = isdat1(isdat)
- isdat2(isdat-numdrop) = isdat2(isdat)
- isdat3(isdat-numdrop) = isdat3(isdat)
- isdat4(isdat-numdrop) = isdat4(isdat)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- isdat4(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv,
- * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc)
-c
-c Called once per main note. (5/26/02) for non-ps slurs only
-c
- parameter (nm=24,mv=24576)
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- character*1 ulq,slurudq,udfq,udqq,chax
- character*79 notexq
- character*8 noteq
- character*80 soutq
- logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove,
- * settie,fontslur,WrotePsslurDefaults
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
-c
-c Bits in isdat1:
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-c
-c Bits in isdat2
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted flag
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c
-c Bits in isdat3: Only used for slur endings
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c
-c In listslur bit ib is on if slur index ib is in use, ib=0-23.
-c ndxslur = slur index
-c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note,
-c s-slur is blank (idcode=32), t-slur is idcode=1.
-c ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
-c Ivoff will be set for ./_ only if no user-defined shift is specified.
-c If highest note has upslur, save slur height in islhgt in case
-c ornament must be moved.
-c
- islhgt = 0
- if (beamon) then
- stemup = ulq .eq. 'u'
- else if (nvmx(iv) .eq. 2) then
- if (.not.btest(islur,30)) then
-c
-c Single note, 2 lines of music, stem direction not forced
-c
- stemup = ivx .gt. nv
- else
- stemup = btest(islur,17)
- end if
- else
- stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
- end if
- iscrd = btest(ipl,10)
- if (btest(islur,1)) then
-c
-c 't'-slur (idcode=1) somewhere on this note. Find it, check height against
-c 's'-slur (idcode=32)
-c
- sfound = .false.
- tfound = .false.
- tmove = .false.
- do 5 isdat = 1 , nsdat
- if (iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * ip .eq. igetbits(isdat1(isdat),8,3) .and.
- * kv .eq. igetbits(isdat1(isdat),1,12)+1) then
- if (.not.tfound) then
- tfound = igetbits(isdat1(isdat),7,19).eq.1
- if (tfound) then
- nolevt = igetbits(isdat2(isdat),7,19)
- isdatt = isdat
- if (sfound) go to 6
- end if
- end if
- if (.not.sfound) then
- sfound = igetbits(isdat1(isdat),7,19).eq.32
- if (sfound) then
- nolevs = igetbits(isdat2(isdat),7,19)
- isdats = isdat
- if (tfound) go to 6
- end if
- end if
- end if
-5 continue
-c
-c Will come thru here if there is a t with no s, so comment out the following
-c print*,'Did not find s+t-slurs in doslur'
-c
-6 continue
- if (sfound .and. tfound)
- * tmove = nolevs.eq.nolevt .and.
-c
-c Check if 2 starts or two stops
-c
- * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or.
- * (.not.btest(isdat1(isdats),11).and.
- * .not.btest(isdat1(isdatt),11)) )
-c
-c This is a flag for later changing slur level, after we know slur dir'n.
-c
- end if
- if (ismidi) then
- settie = .false.
- dbltie = .false.
- end if
- do 1 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- if (iv .eq. igetbits(isdata,5,13) .and.
- * ip .eq. igetbits(isdata,8,3) .and.
- * kv .eq. igetbits(isdata,1,12)+1) then
-c
-c Since iv and kv match, ivx will be correct
-c
- idcode = igetbits(isdata,7,19)
- ivoff = igetbits(isdat2(isdat),6,6)-32
- ihoff = igetbits(isdat2(isdat),7,12)-64
- iupdn = 0
- slurudq = 'd'
- nolevs = igetbits(isdat2(isdat),7,19)
- if (btest(isdata,11)) then
-c
-c Turnon,
-c
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Note was a rest, cannot start slur on rest.
-c
- print*
- call printl('Cannot start slur on a rest')
- call stop1()
- end if
-c
-c Get slur direction
-c
- if (btest(isdata,26)) then
-c
-c Force slur direction
-c
- if (btest(isdata,27)) slurudq = 'u'
- else if (nvmx(iv) .eq. 1) then
-c
-c Only one voice per line
-c
- if (.not.beamon) then
-c
-c Separate note.
-c
- slurudq = udfq(nolev,ncm)
- else
-c
-c In a beam
-c
- if (ulq .ne. 'u') slurudq = 'u'
- end if
- if (iscrd) then
- if (nolevs .gt. ncm) then
- slurudq = 'u'
- else
- slurudq = 'd'
- end if
- end if
- else
-c
-c Two voices per line. Get default
-c
- if (ivx .gt. nv) slurudq = 'u'
-c
-c Upper voice of the two, so up slur
-c
- end if
-c
-c Save up/down-ness for use at termination
-c
- if (slurudq .eq. 'u') isdata = ibset(isdata,27)
-c
-c End of section for setting slur direction, still in "Turnon" if-block.
-c
- if (idcode.eq.1 .and. tmove) then
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- end if
- if (btest(iornq,11).or.btest(iornq,12)) then
-c
-c Raise or lower slur by one unit provided . or _ is on same side as slur
-c
- ivoffinc = 0
- if ((stemup .and. slurudq.eq.'d') .or.
- * (.not.stemup .and. slurudq.eq.'u')) then
-c
-c Must move the slur for _ or .
-c
- if (stemup) then
- ivoffinc = -1
- else
- ivoffinc = 1
- end if
- if (((stemup .and. nolev.ge.ncm-2) .or.
- * (.not.stemup .and. nolev.le.ncm+2)) .and.
- * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
- ivoff = ivoff+ivoffinc
- end if
- end if
- if (listslur .eq. 16777215) then
- print*
- print*,'You1 defined the twenty-fifth slur, one too many!'
- write(15,'(/,a)')
- * 'You2 defined the twenty-fifth slur, one too many!'
- call stop1()
- end if
-c
-c Get index of next slur not in use, starting from ? down
-c
- ndxslur = log2(16777215-listslur)
-c
-c Record slur index
-c
- listslur = ibset(listslur,ndxslur)
-c
-c Save for use on termination
-c
-c call setbits(isdata,4,28,ndxslur)
-c 080531 Allow >16 slurs
- call setbits(isdata,4,28,mod(ndxslur,16))
- call setbits(isdata,1,18,ndxslur/16)
-c
-c Shift for stem?
-c
- if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.)
- * ihoff = ihoff+8
- if (btest(isdat2(isdat),3)) then
-c
-c Tie spacing, (slur start)
-c
- if (slurudq.eq.'d') then
- ivoff = ivoff+1
- ihoff = ihoff+8
- else if (slurudq.eq.'u') then
- ivoff = ivoff-1
- if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8
-c
-c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u')
-c
- end if
- end if
- if (iscrd) then
-c
-c Additional horiz shifts for h-shifted noteheads?
-c
- if (btest(isdat2(isdat),1)) then
-c
-c Slur start on left-shifted chord notehead. ASSUME downstem.
-c
- if (nolevs.eq.minlev .and. slurudq.eq.'d') then
- ihoff = ihoff-2
- else
- ihoff = ihoff-10
- end if
- else if (btest(isdat2(isdat),2)) then
-c
-c Right shifted chord notehead. ASSUME upstem.
-c
- if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
- ihoff = ihoff+2
- else
- ihoff = ihoff+10
- end if
- end if
- end if
- if (ihoff .eq. 0) then
-c
-c Write stuff for non-shifted start
-c
- notexq = chax(92)//'islur'//slurudq
- lnote = 7
- else
- notexq = chax(92)//'is'//slurudq
- lnote = 4
- end if
- if (btest(isdat2(isdat),4)) then
-c
-c Dotted slur
-c
- noteq = notexq
- notexq = chax(92)//'dotted'//noteq
- lnote = lnote+7
- end if
-c
-c Add slur index to string
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c
-c 5/25/08 Allow 24 slurs
-c
-c notexq = notexq(1:lnote)//chax(59-ndxslur)
- notexq = notexq(1:lnote)//chax(71-ndxslur)
- lnote = lnote+1
- else if (23-ndxslur .lt. 20) then
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}'
- notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}'
- lnote = lnote+4
- end if
-c
-c Add note name to string
-c
- call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
-c
-c Save height (for ornament and barnobox interference) if topmost slur is up
-c
- if (slurudq.eq.'u' .and.
- * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
- islhgt = nolevs+iupdn+ivoff
-c
-c Save height & idcode if top voice and slur start
-c
- if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
- is1n1 = islhgt
- is2n1 = idcode
- end if
- end if
- if (ihoff .ne. 0.) then
- shift = ihoff*0.1
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- lform = lfmt1(shift)
- write(notexq(lnote+1:lnote+lform),'(f'//
- * chax(48+lform)//'.1)') shift
- lnote = lnote+lform
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq,lnote,soutq,lsout)
-c
-c Zero out ip1 to avoid problems if slur goes to next input blk.
-c
- call setbits(isdata,8,3,0)
-c
-c Set slur-on data for midi. Only treat null-index slurs and ps ties for now.
-c
- if (ismidi .and. idcode.eq.32) then
- levson(midchan(iv,kv)) = nolevs
- if (settie) dbltie = .true.
-c
-c Only way settie=T is if we just set a tie ending. So there's also a slur
-c start here, so set a flag telling addmidi not to zero out levson
-c
- end if
- else
-c
-c Slur is ending. Back thru list to find starting slur
-c
- do 3 j = isdat-1 , 1 , -1
- if (iv.eq.igetbits(isdat1(j),5,13) .and.
- * kv.eq.igetbits(isdat1(j),1,12)+1) then
- if (idcode .eq. igetbits(isdat1(j),7,19)) then
- ndxslur = igetbits(isdat1(j),4,28)
-c
-c 080531 Allow >16 slurs
-c
- * +16*igetbits(isdat1(j),1,18)
- if (btest(isdat1(j),27)) slurudq = 'u'
- go to 4
- end if
- end if
-3 continue
- print*,'Bad place in doslur'
- call stop1()
-4 continue
- if (nolevs.eq.0 .or. nolevs.gt.60) then
-c
-c Ending is on a rest, reset nolevs to default starting height
-c
- nolevs = igetbits(isdat2(j),7,19)
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Deal with \curve or \midslur
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Remember, only dealing with non-ps slurs
-c
-c Who knows where the following line came from. Removed it 6/30/02 to
-c restore behavior of non-ps slurs to old way
-c if (slurudq .eq. 'd') imid = -imid
-c 3/8/03 added the following
-c
- if (slurudq .eq. 'd') imid = -abs(imid)
-c
- if (btest(isdat3(isdat),1)) then
- notexq = chax(92)//'curve'
- lnote = 6
- else
- notexq = chax(92)//'midslur'
- lnote = 8
- end if
- if (imid.lt.0 .or. imid.gt.9) then
-c
-c Need brackets
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (imid .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')imid
- lnote = lnote+3
- else if (imid.lt.0 .or. imid.gt.9) then
- write(notexq(lnote+1:lnote+2),'(i2)')imid
- lnote = lnote+2
- else
- write(notexq(lnote+1:lnote+1),'(i1)')imid
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
-c
-c 1=<imid=<9, no brackets
-c
- notexq = notexq(1:lnote)//char(48+imid)
- lnote = lnote+1
- end if
- if (btest(isdat3(isdat),1)) then
-c
-c \curve; 3 args
-c
- notexq = notexq(1:lnote)
- * //char(48+igetbits(isdat3(isdat),3,8))
- notexq = notexq(1:lnote+1)
- * //char(48+igetbits(isdat3(isdat),3,11))
- lnote = lnote+2
- end if
- call addstr(notexq,lnote,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.)
- * ihoff = ihoff-8
- if (btest(isdat2(isdat),3)) then
-c
-c Shift ending for tie spacing
-c
- if (slurudq .eq. 'u') then
- ihoff = ihoff-8
- ivoff = ivoff-1
- else if (slurudq .eq. 'd') then
- ivoff = ivoff+1
- if (stemup.or. tno.gt.63.) ihoff = ihoff-8
- 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 Print 23-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
- if (idcode.eq.1 .and. tmove) then
-c
-c t-slur height adjustment
-c
- iupdn = 1
- if (slurudq .eq. 'd') iupdn = -1
- 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
- isdat1(j) = 0
- isdat2(j) = 0
- isdat3(isdat) = 0
-c
-c Set midi info for slur ending
-c
- if (ismidi .and. idcode.eq.32) 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)
- isdat1(isdat) = 0
- isdat2(isdat) = 0
- isdat3(isdat) = 0
- end if
-2 continue
- nsdat = nsdat-numdrop
-c call report(nsdat,isdat1,isdat2)
- return
- end
- subroutine dotmov(updot,rtdot,soutq,lsout,iddot)
-c
-c iddot = 0 for single dot, 1 for double
-c
- character*80 soutq,notexq
- character*1 sq,chax
- sq = chax(92)
- lfmtup = lfmt1(updot)
- lfmtrt = lfmt1(rtdot)
- write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt)
- * //'.1,a15)')
- * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq//
- * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq
- * //'makeatother'
-c
-c Example of string just created:
-c \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\
-c
- lnote = 54+lfmtup+lfmtrt
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
- return
- end
- subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
- 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*1 chax
- character*8 noteq
- character*79 notexq
- logical tronly,btest
- do 1 itr = 1 , ntrill
- if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
-1 continue
- print*,'Problem in dotrill. Call Dr. Don'
- stop
-2 continue
- tronly = xnsktr(itr) .lt. 0.01
- if (tronly) then
- notexq = chax(92)//'zcharnote'
- lnote = 10
- else if (btest(iornq,7)) then
- notexq = chax(92)//'Trille'
- lnote = 7
- else
- notexq = chax(92)//'trille'
- lnote = 7
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
- lnote = lnote+lnoten+1
-c
-c Write trill duration to nearest tenth of a noteskip
-c
- if (tronly) then
- notexq = notexq(1:lnote)//chax(92)//'it tr}'
- lnote = lnote+7
- return
- end if
- if (xnsktr(itr) .lt. .95) then
- nfmt = 2
- else if (xnsktr(itr) .lt. 9.95) then
- nfmt = 3
- else
- nfmt = 4
- end if
- write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)')
- * xnsktr(itr)
- lnote = lnote+nfmt
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- return
- end
- subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
- * soutq,lsout,fontslur)
-c
-c Only called to end slur started in dograce.
-c
- logical shift,stemup,upslur,fontslur
- character*80 soutq
- character*79 notexq
- character*8 noteq
- character*1 chax
- shift = .not.stemup .and. .not.upslur
- if (.not.shift) then
-c
-c No shift needed
-c
- notexq = chax(92)//'tslur'
- lnote = 6
- else
-c
-c Shift needed
-c
- notexq = chax(92)//'ts'
- lnote = 3
- end if
-c if (ndxslur .lt. 10) then
-c notexq = notexq(1:lnote)//chax(48+ndxslur)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
-c lnote = lnote+4
-c end if
-c
-cc Print 11-ndxslur
-c Print 23-ndxslur
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-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
- call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- if (shift) then
- if (fontslur) then
- notexq = notexq(1:lnote)//'{-.6}'
- else
- notexq = notexq(1:lnote)//'{-.8}'
- end if
- lnote = lnote+5
- end if
- call addstr(notexq,lnote,soutq,lsout)
- return
- end
- subroutine errmsg(lineq,iccount,ibarno,msgq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*128 lineq
- character*78 outq
- character*(*) msgq
- character*1 chax
- common /truelinecount/ linewcom(20000)
- if (iccount .le. 78) then
- outq = lineq(1:78)
- iposn = iccount
- else
- outq = '... '//lineq(55:128)
- iposn = iccount-50
- end if
- print*
- ibarnop = ibarno
- if (linesinpmxmod.eq.0 .or.
- * nline .gt. line1pmxmod+linesinpmxmod) then
-c
-c Error is in main .pmx file
-c
-c nlinep = nline-linesinpmxmod
-c Correct for comments not copied into buffer
- nlinep = linewcom(nline)-linesinpmxmod
- else
-c
-c Error is in include file
-c
- ibarnop = 0
- nlinep = nline-line1pmxmod+1
- call printl(
- * 'ERROR in include file named above, description given below')
- end if
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') nlinep
- close(19)
- ndigbn = max(1,int(log10(ibarnop+.1)+1))
- ndignl = int(log10(nlinep+.1)+1)
- lenmsg = index(msgq,'!')-1
-c
-c Split off msgq(..) since UNIX compilers don't allow concat substring!!!
-c
- write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(*,'(1x,a)')msgq(1:lenmsg)
- write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
- *',$)')' ERROR in line ',nlinep,', bar ',ibarnop
- write(15,'(a)')msgq(1:lenmsg)
- i10 = iposn/10
- i1 = iposn-10*i10
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
- print*,outq(1:78)
- write(15,'(a)')' '//outq(1:78)
- write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
- return
- end
- subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
-c
-c Get elemskips to previous note. Called only for graces, no xtups involved.
-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)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- real*4 tstart(80),space(80)
- common /comtol/ tol
- itnd = nint(to(in))
- if (ip.eq.1 .or. itnd.eq.itrpt) then
-c
-c Start of bar or after rpt.
-c
- esk = fbar
- return
- else
- esk = 0.
- itprev = itnd-nodur(ivx,ip-1)
- do 1 iib = ib , 1 , -1
- if (tstart(iib) .lt. itprev+tol) then
-c
-c This is the block
-c
- nnsk = nint(float((itnd-itprev))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- return
- else
- nnsk = nint((itnd-tstart(iib))/space(iib))
- esk = esk+nnsk*feon(space(iib))
- itnd = nint(tstart(iib))
- end if
-1 continue
- end if
- print*,'Problem in eskb4. Send files to Dr. Don'
- stop
- end
- function f1eon(time)
- f1eon = sqrt(time/2)
- return
- end
- function feon(time)
- common /comeon/ eonk,ewmxk
- feon = sqrt(time/2)**(1.-eonk)*ewmxk
- return
- end
- subroutine findbeam(ibmrep,numbms,mapfb)
-c
-c Called once per voice per bar, after setting forced beams.
-c
- parameter (nm=24)
- dimension mask(49,3),nummask(3),eqonly(49,3)
-c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16),
-c * itr(48),nodue(48)
-c logical short(48),eqonly
- integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(16),
- * itr(248),nodue(248)
- logical short(248),eqonly
- 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)
- common /combeam/ ibmtyp
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,btest
- data nip1,nip2 /496*0/
- data nummask / 29 , 49 , 12 /
- data mask
- * / 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, 20*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,
- * 37*0 /
- data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
- ip = 0
- nreal = 0
- itnow = 0
-1 continue
- ip = ip+1
- if (ip .gt. nn(ivx)) go to 9
-11 if (nodur(ivx,ip).eq.0) then
-c
-c Ignore all xtup notes except the last, the one with nodur > 0 .
-c Xtups are irrelevant here since they are already all in forced beams.
-c Will update itnow by nodur at the END of this loop
-c
- ip = ip+1
- go to 11
- end if
- nreal = nreal+1
- nodue(nreal) = nodur(ivx,ip)
- short(nreal) = nodue(nreal).lt.16 .and.
- * .not.btest(irest(ivx,ip),0)
-c
-c Rule out notes that have 'alone'-flag set
-c
- * .and..not.btest(islur(ivx,ip),18)
- ipr(nreal) = ip
- itr(nreal) = itnow
- if (nodue(nreal) .eq. 1) then
-c
-c 64th gap
-c
- if (mod(itnow,2) .eq. 0) then
-c
-c Start of 32nd gap, lump with following note
-c
- ip = ip+1
- nodue(nreal) = 1+nodur(ivx,ip)
- itnow = itnow+nodue(nreal)
- else
-c
-c End of 32nd gap, lump with preceeding note
-c
- nreal = nreal-1
- nodue(nreal) = 1+nodue(nreal)
- itnow = itnow+1
- end if
- else
- itnow = itnow+nodur(ivx,ip)
- end if
- go to 1
-9 continue
- ir1 = 1
- itseg = lenbar/ibmrep
- do 13 irep = 1 , ibmrep
-c
-c Set bitmaps for all shorts neighbored by a short. Each bit represents a
-c span of 32nd note. maps, mapm, mape record start, full duration, and end
-c of consecutive span of beamable (<1/4) notes.
-c
- maps = 0
- mapm = 0
- mape = 0
- itend = itseg*irep
- itoff = itend-itseg
- do 2 ir = ir1 , nreal
- it2 = itr(ir)+nodue(ir)-2
- if (it2 .ge. itend) then
- ir1 = ir
- go to 14
- end if
-c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal
- if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or.
- * (ir.lt.nreal.and.short(ir+1)))) then
- ib1 = (itr(ir)-itoff)/2
- ib2 = (it2-itoff)/2
- if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or.
- * min(ib1,ib2).lt.0) return
-c
-c Must have an odd number obe beats in a long bar. Auto-beam won't work
-c
- nip1(ib1) = ipr(ir)
- nip2(ib2) = ipr(ir)
-c
-c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip
-c
- maps = ibset(maps,ib1)
- mape = ibset(mape,ib2)
- do 3 ib = ib1 , ib2
- mapm = ibset(mapm,ib)
-3 continue
- end if
-2 continue
-14 continue
- if (mapm .eq. 0) go to 13
-c
-c Zero out bits from forced beams
-c
- maps = iand(maps,not(mapfb(irep)))
- mapm = iand(mapm,not(mapfb(irep)))
- mape = iand(mape,not(mapfb(irep)))
-c
-c Compare map with template.
-c
- do 4 it = 1 , nummask(ibmtyp)
- masknow = mask(it,ibmtyp)
- if (iand(masknow,mapm) .eq. masknow) then
-c
-c Find least significant bit in the mask to check start time
-c
- mtemp = masknow
- maskm = masknow
- do 5 is1 = 0 , 47
- if (iand(1,mtemp) .eq. 1) go to 6
- mtemp = ishft(mtemp,-1)
-5 continue
-6 continue
- if (iand(ishft(1,is1),maps) .eq. 0) go to 4
-c
-c is1 is the bit where the beam starts. Continue shifting to
-c find most significant bit in the mask to check ending time
-c
- do 7 is2 = is1 , 47
- mtemp = ishft(mtemp,-1)
- if (iand(1,not(mtemp)) .eq. 1) go to 8
-7 continue
-8 continue
-c
-c is2 is now the bit on which the beam ends.
-c
- if (iand(ishft(1,is2),mape) .eq. 0) go to 4
-c
-c Did we pick out a single note from the middle of a longer sequence?
-c
- if (nip1(is1) .eq. nip2(is2)) go to 4
-c
-c We almost have a beam. Check equality of notes if needed.
-c
- if (eqonly(it,ibmtyp)) then
- do 10 ip = nip1(is1) , nip2(is2)
- if (nodur(ivx,ip) .ne. 8) then
-c
-c There is a non-1/8th note in this beam. Exit if not 2 quarters
-c
- if (is2-is1 .ne. 15) go to 4
-c
-c Beam is 2 quarters long. Check if can split in half.
-c
- ithalf = 0
- do 20 iip = nip1(is1) , nip2(is2)
- ithalf = ithalf+nodur(ivx,iip)
- if (ithalf .gt. 16) go to 4
- if (ithalf .eq. 16) go to 21
-20 continue
- print*,'Problem in findbeam, please call Dr. Don'
- go to 4
-21 continue
-c
-c Otherwise, split in half by keeping only the first half. Other half will
-c be picked up later, assuming masks are listed longest first.
-c
- is2 = is1+7
-c
-c Reset maskm (since only used part of mask), used later to zero out
-c bits that contain beams
-c
- maskm = 0
- do 15 is = is1 , is2
- maskm = ibset(maskm,is)
-15 continue
- go to 16
- end if
-10 continue
- end if
-16 continue
-c
-c This is a beam. If last "effective" ends on odd 64th, add 1 more
-c
-c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2))))
-c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then
- if (abs(amod(to(ipl2(ivx,nip2(is2)))
- * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then
- nip2(is2) = nip2(is2)+1
- end if
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
- call logbeam(numnew,nip1(is1),nip2(is2))
-c
-c Zero out the appropriate bits so these notes don't get used again
-c
- mapm = iand(mapm,not(maskm))
- if (mapm.eq.0) go to 13
- maps = iand(maps,not(maskm))
- mape = iand(mape,not(maskm))
- end if
-4 continue
-13 continue
- return
- end
- subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0)
- parameter (nkb=3999,maxblks=4000)
-c
-c Compute an exponent eonk for use in the "flattened" formula for elemskips
-c vs time. We must solve the eqution f = 0. Initial quess is eonk0.
-c
- logical gotclef
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /comtol/ tol
- common /comeon/ eonk,ewmxk
- eonk = eonk0
- niter = 0
-1 continue
- ewmxk = f1eon(dtmax)**eonk
- niter = niter+1
- esum = 0.
- desum = 0.
- do 2 iptr = nptr1 , nptr2
- targ = durb(iptr)/sqzb(iptr)
- esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ)
- detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ)
- desum = desum+nnpd(iptr)*sqzb(iptr)*detarg
-2 continue
- f = wovera*feon(dtmin)-xelsk-esum
- fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin)
- * -desum
- if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then
- call printl(
- * 'Error in findeonk. Please send source to Dr. Don')
- eonk = 0.
- ewmxk = 1.
- return
- end if
- dsoln = -f/fp
- if (abs(dsoln) .lt. .1*tol) return
-c
-c Not converged yet, try again
-c
- eonk = eonk+dsoln
- go to 1
- end
- function fnote(nodur,ivx,ip,nacc)
-c
-c This return the real duration of a note
-c
- parameter (nm=24)
- integer*4 nodur(nm,200),nacc(nm,200)
- logical btest
- ipback = ip
- if (nodur(ivx,ip) .gt. 0) then
- if (ip .gt. 1) then
-c
-c Check if this is last note of xtup
-c
- if (nodur(ivx,ip-1).eq.0) then
- ipback = ip-1
- go to 2
- end if
- end if
- fnote = nodur(ivx,ip)
- return
- end if
-2 continue
-c
-c Count back to prior non zero note. Start at ip to avoid neg index if ip=1.
-c Count how many doubled xtups notes there are from ip-1 to first note.
-c
- ndoub = 0
- do 1 ip1m1 = ipback , 1 , -1
- if (nodur(ivx,ip1m1) .gt. 0) go to 4
- if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1
-1 continue
-4 continue
-c
-c count forward to next non-0 nodur. Start at ip in case last note of xtup.
-c
- do 3 iip = ip , 200
-c
-c Count doubled xtup notes from ip to end.
-c
- if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1
- if (nodur(ivx,iip) .gt. 0) then
-c fnote = nodur(ivx,iip)/float(iip-ip1m1)
- fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub)
- if (btest(nacc(ivx,ip),18)) then
- fnote = 2*fnote
- else if (btest(nacc(ivx,ip),27)) then
- fnote = 1.5*fnote
- else if (ip .gt. 1) then
- if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote
- end if
- return
- end if
-3 continue
- print*,' '
- call printl
- * ('Probable misplaced barline or incorrect meter, stopping')
-c call printl('Program error in fnote, send source to Dr. Don')
- call stop1()
- end
- subroutine g1etchar(lineq,iccount,charq)
- parameter(nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,issegno,isheadr,isvolt,fbon
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- character*1 charq
- character*128 lineq,lnholdq
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not.endmac) then
- iccount = 0
- if (.not.mplay) nline = nline+1
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
- end
- subroutine g1etnote(loop,ifig,optimize,fulltrans)
- parameter (nm=24,nkb=3999,mv=24576,maxblks=4000)
- character*1 chax
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend,
- * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt,
- * stickyS
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- logical mrecord,mplay,endmac,shifton,gotclef,optimize
- character*128 lineq,lnholdq
- character*1 charq,dotq,dumq,durq,charlq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical novshrinktop,upslur,fontslur,ztrans,
- * WrotePsslurDefaults,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- character*51 literq(3)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- common /comsize/ isize(nm)
- data literq
- * /'Literal TeX string cannot start with 4 backslashes!',
- * 'TeX string must have <129 char, end with backslash!',
- * 'Type 2 or 3 TeX string can only start in column 1!'/
- cdot = .false.
-1 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') charlq = charq
- if (lastchar) then
- if (index('/%',charlq) .eq. 0) then
- print*
- print*,'WARNING:'
- print*,'Last non-blank character is "',charlq,'", not "/,%"'
- print*,'ASCII code:',ichar(charlq)
- write(15,'(/a)')'Last non-blank character is "'//charlq//
- * '", not "/,%"'
- write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq)
-c
-c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1.
-c
- ilbuf = ilbuf-1
- lbuf(ilbuf) = lbuf(ilbuf)+2
- bufq = bufq(1:ipbuf)//' /'
- write(15,*)'appending <blank>/'
- print*,'appending <blank>/'
- lineq = lineq(1:iccount)//' /'
- lastchar = .false.
- go to 1
- end if
- return
- end if
- if (charq .eq. ' ') then
- go to 1
- else if (charq.eq.'%' .and. iccount.eq.1) then
- iccount = 128
- go to 1
-c
-c Replacement 1/22/12 since gfortran 4.7 with -O was choking here!
-c
-c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- else if (index('abcdefg',charq).gt.0 .or.
- * charq.eq.'r') then
-c
-c This is a note/rest. gotclef is only used for checking for clef before "/"
-c
- if (cdot) go to 28
- if (gotclef) gotclef=.false.
- idotform = 0
- numnum = 0
- plusmin = .false.
-28 nnl(ivx) = nnl(ivx)+1
- if (nnl(ivx) .gt. 200) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>200 notes in line of music. Use smaller blocks!')
- call stop1()
- end if
- dotq = 'x'
-c
-c Check if this is 'r ' and previous note was full-bar-pause
-c
- fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and.
- * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar
-2 call g1etchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- if (charq .eq. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one digit allowed after rest symbol "r"!')
- call stop1()
- end if
- numnum = 2
- if (plusmin) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '>2 digits in note symbol!')
- call stop1()
- end if
- else if (durq.eq.'d') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
- iddot = 1
- iccount = iccount+1
-c
-c Since we flow out, double dots won't work with other dot options
-c
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, provided a number follows.
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
-c
-c Backup, exit the loop normally
-c
- iccount = iccount-2
- go to 2
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789-.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after 2nd +/- (shift dot)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (index('<>',durq) .gt. 0) then
-c
-c Accidental shift
-c
-c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
-c * 'Expected "f", "s", or "n" before "<" or ">"!')
- * 'Expected "f", "s", "n" or "A" before "<" or ">"!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '<') ipm=-1
- call g1etchar(lineq,iccount,durq)
- if (index('123456789.0',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected number after </> (accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horizontal accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else if (index('+-',durq) .gt. 0) then
- if (charq .ne. 'r') then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then
- ipm = 1
- if (durq .eq. '-') ipm=-1
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .gt.0) then
-c
-c This may be start of accidental shift, but may be octave jump; then duration
-c
- icsav = iccount
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .gt. 0) then
-c
-c This is an accid shift since there's a 2nd consecutive signed number.
-c Check size of 1st number.
-c
- if (fnum .gt. 30.5) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Vertical accidental shift must be less than 31!')
- call stop1()
- end if
- ipm = 1
- if (durq .eq. '-') ipm = -1
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected 2nd number of accidental shift)!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- fnum = ipm*fnum
- if (fnum.lt.-5.35 .or. fnum.gt.1.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Horiz. accidental shift must be >-5.35 and <1.0!')
- call stop1()
- end if
- iccount = iccount-1
- go to 2
- else
-c
-c Not accid shift, reset, then flow out
-c
- iccount = icsav
- end if
- end if
- end if
- plusmin = .true.
- if (numnum .eq. 2) then
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Before version 1.2, +/- was ignored if octave was!')
- print*,
- * 'explicitly specified. May need to edit old editions'
- end if
- go to 2
-c
-c It's a rest containing +|- . Must refer to a vertical shift. Read past.
-c
- else
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,dum)
- iccount = iccount-1
- go to 2
- end if
-c else if (index('ulare',durq) .gt. 0) then
- else if (index('ularec',durq) .gt. 0) then
- go to 2
- else if (durq .eq. 'S') then
-c
-c Stemlength change
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789:',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a number or colon here!')
- call stop1()
- end if
- if (durq .eq. ':') then
- if (.not.stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned off sticky stemshrinks without turning on!')
- call stop1()
- end if
- stickyS = .false.
- go to 2
- end if
- call readnum(lineq,iccount,durq,dum)
- if (dum.lt..5 .or. dum.gt.4.) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Stemlength shortening must be from .5 to 4!')
- call stop1()
- end if
- if (durq .ne. ':') then
- iccount = iccount-1
- else
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on sticky stemshrinks when already on!')
- call stop1()
- end if
- stickyS = .true.
- end if
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 2
- else if (durq .eq. 'p') then
- fulbrp = charq.eq.'r'
- if (.not. fulbrp) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'The option "p" only works with "r" (rest)!')
- call stop1()
- end if
- go to 2
- else if (durq .eq. 'b') then
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "b"; I expected "rb"!')
- call stop1()
- else if (numnum .eq. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You entered "r" & "b" with two numbers!')
- end if
- go to 2
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Will set all durations to 0 except last one.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'First char after "x" in xtuplet must be "1"-"9"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (fnum .gt. 99) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Xtuplet cannot have more than 99 notes!')
- call stop1()
- else if (index(' DFnd',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only legal characters here are " ","D","F","n"!')
- call stop1()
- end if
-c
-c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n.
-c
- if (index('DF',durq) .gt. 0) then
-c
-c Double xtup note to make an un= xtup. Here, number already set, but may also
-c have used this before number was set.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = 1
- call g1etchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call g1etchar(lineq,iccount,durq)
- end if
- if (durq .eq. 'n') then
-c
-c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'.
-c
- numshft = 0
-30 call g1etchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
- go to 30
- else if (index('+-',durq) .gt. 0) then
- numshft = numshft+1
- if (numshft .eq. 3) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only 2 shifts are allowed after "n" in xtup!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit or "."!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
- if ((numshft.eq.1 .and. snum.gt.15.1) .or.
- * (numshft.eq.2 .and. snum.gt.1.51)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Shift number after "n" in xtup is out of range!')
- call stop1()
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope alteration for bracket
-c
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'For slope adjustment, this character must be "+" or "-"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character should be a digit!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,snum)
- iccount = iccount-1
- if (nint(snum) .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slope adjustment cannot exceed 15!')
- call stop1()
- end if
- go to 30
- else if (index('123456789',durq) .gt. 0) then
-c
-c Unsigned integer => alternate printed number
-c
- call readnum(lineq,iccount,durq,snum)
- if (snum .gt. 15.1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Alternate xtup number after "n" must be <16!')
- call stop1()
- end if
- iccount = iccount-1
- go to 30
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "n" in xtup!')
- call stop1()
- end if
- end if
- ntup = nint(fnum)
- do 6 itup = 2 , ntup
- nodur(ivx,nnl(ivx)) = 0
- nnl(ivx) = nnl(ivx)+1
-110 call g1etchar(lineq,iccount,durq)
- if (durq.eq.' ') then
- go to 110
- else if (durq .eq. 'o') then
-c
-c Ornament in xtup. "o" symbol must come AFTER the affected note
-c
- call g1etchar(lineq,iccount,dumq)
- if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then
- if (index('fg',dumq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Fermata or segno not allowed in xtuplet!')
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- end if
- call stop1()
- end if
- if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-29 call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') go to 29
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,
- * ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
- go to 110
- else if (index('st(){}',durq) .gt. 0) then
-c
-c Slur in xtup
-c
- iposn = 0
- numint = 0
-15 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (index('udlbfnht',dumq) .gt. 0) then
- if (dumq.eq.'t' .and. durq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- go to 15
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum).gt.6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in the range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 40 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,
- * ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-40 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 15
-
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 15
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H')
- * iccount=iccount+1
- go to 15
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- go to 15
- else if (dumq .ne. ' ') then
- ic = ichar(dumq)
- if ((ic.ge.48.and.ic.le.57) .or.
- * (ic.ge.65.and.ic.le.90)) then
- if (iposn .eq. 1) then
- if (durq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- end if
- go to 15
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be 2nd character in slur symbol!')
- call stop1()
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- end if
- go to 110
- else if (index('0123456789#-nx_',durq) .gt. 0) then
-c
-c We have a figure. Only allow on 1st note of xtup
-c
- if (itup .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Figure in xtup only allowed on 1st note!')
- call stop1()
- else if (durq.eq.'x') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'No floating figures in xtuplets!')
- call stop1()
- end if
- if (usefig .and. ivx.eq.1) ifig = 1
-26 call g1etchar(lineq,iccount,durq)
- if (index('0123456789#-n_.:',durq) .gt. 0) then
- go to 26
- else if (durq .eq. 's') then
- isligfont = .true.
- go to 26
- else if (durq .eq. '+') then
-c
-c vertical offset, must be integer then blank
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .ne. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 26
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure in xtuplet!')
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'G') then
- ngr = 1
-79 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 79
- else if (index('AWulxs',charq) .gt. 0) then
- go to 79
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 79
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 79
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 71 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-75 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 75
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-78 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 78
- else if (index('+-nfs',charq) .gt. 0) then
- go to 78
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-71 continue
- go to 110
- else if (durq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- go to 110
- else if (durq .eq. 'M') then
-c
-c Temporary trap until I get around putting this in pmxb
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macros not yet allowed in xtuplets!')
- call stop1()
- else if (durq .eq. 'X') then
- call g1etx(lineq,iccount,.false.,shifton,
- * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt)
- go to 110
- else if (durq .eq. 'z') then
-c
-c Chord note in xtup. Read past for now.
-c
-33 call g1etchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 33
- go to 110
- else if (durq .eq. 'D') then
-c
-c Dynamic mark
-c
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- go to 110
- else if (durq .eq. '%') then
- if (iccount .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Comment must have "%" in column 1!')
- call stop1()
- end if
- iccount = 128
- go to 110
- else if (durq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- go to 110
- end if
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 110
-c+++
- else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'['
- * .and. lineq(iccount+2:iccount+2).eq.' ') then
- iccount = iccount+2
- go to 110
-c+++
- end if
-c
-c End of xtup options. At this point symbol can only be note or rest
-c
- if (index('abcdefgr',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In xtup, this character is not allowed!')
- call stop1()
- else if (durq.eq.'r' .and. itup.eq.ntup) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry, PMX cannot end an xtuplet with a rest!')
- call stop1()
- end if
-7 call g1etchar(lineq,iccount,durq)
- if (index('2345678ulcb',durq) .gt. 0) then
- go to 7
- else if (index('sfn',durq) .gt. 0) then
-c
-c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift.
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 7
- else if (index('+-<>',durq) .gt. 0) then
-c
-c May have either octave jump or shifted accid. on main xtup note
-c
- if (index('+-',durq).gt.0 .and.
- * index('01234567890',lineq(iccount+1:iccount+1)).eq.0)
- * go to 7
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 7
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- ndoub = ndoub+1
- go to 7
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- go to 7
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal option on xtuplet note!')
- call stop1()
- end if
- if (itup .eq. ntup-ndoub) go to 3
-6 continue
-3 continue
-c
-c 6==End of loop for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c
- if (mod(itsofar(iv),lenbar) .ne. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest must start at beginning of bar!')
- call stop1()
- else if (iv.eq.1.and.ibarmbr.gt.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Multibar rest only OK at one time per block!')
- call stop1()
- end if
-c
-c For some purposes, pretend its one bar only
-c
- nodur(iv,nnl(iv)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
-c20 call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer after "rm"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mbrest = nint(fnum)
- iccount = iccount-1
-c if (ichar(durq).ge.48.and.ichar(durq).le.57) then
-c mbrest = 10*mbrest+ichar(durq)-48
-c go to 20
-c end if
- if (nv .gt. 1) then
- if (iv .eq. 1) then
- mbrestsav = mbrest
- else
- if (mbrest .ne. mbrestsav) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must enter same multi-bar rest in every voice!')
- call stop1()
- end if
- end if
-c
-c Zero out mbrestsav so can check at end of input block whether
-c all voices have one
-c
- if (iv .eq. nv) mbrestsav=0
- end if
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "rm"!')
- call stop1()
- end if
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. ',') then
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (index('oL',durq) .gt. 0) then
-c
-c Suppress full bar rest, or look left for height
-c
- if (charq .ne. 'r') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o","L" options only legal for rest, not note!')
- call stop1()
- end if
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" or "F" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Main note accidental option
-c
- call getchar(lineq,iccount,durq)
- if (index('o+-<>',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o",+","-","<",">" are the only legal options here!')
- call stop1()
- end if
-c
-c Need more stuff here
-c
- if (durq .ne. "o") then
-c
-c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will
-c proceed to number input checking
-c
- iccount = iccount-1
- end if
- go to 2
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character!')
- print*,'ASCII code:',ichar(durq)
- call stop1()
- end if
-c
-c End of block for note options.
-c
-c Set the duration
-c
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
- nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
-c
-c Check for double dot
-c
- if (iddot .eq. 1) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- iddot = 0
- end if
- else if (fulbrp) then
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- fulbrp = .false.
- end if
- rest(ivx,nnl(ivx)) = charq.eq.'r'
-c
-c If inside forced beam, check if note is beamable
-c
- if (fbon) then
- if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120
- if (nnl(ivx) .gt. 1) then
- if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120
- end if
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unbeamable thing in forced beam!')
- call stop1()
- end if
-120 continue
-c
-c Get number of prior bars for later check on whether note spans bar line
-c
- nbb4 = itsofar(ivx)/lenbar
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (mod(itsofar(ivx),lenbar) .eq. 0) then
- nbars = nbars+1
- if (shifton) barend = .true.
-c
-c Will check barend when 1st note of next bar is entered.
-c
- if (nbars .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have more than 15 bars in an input block!')
- call stop1()
- end if
- nib(ivx,nbars) = nnl(ivx)
- if (firstline .and. lenbar.ne.lenbr1) then
-c
-c Just finished the pickup bar for this voice.
-c
- if (itsofar(ivx) .ne. lenbr0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Pickup bar length disagrees with mtrnum0!')
- call stop1()
- end if
- lenbar = lenbr1
- itsofar(ivx) = 0
- end if
- else if (barend) then
- if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- barend = .false.
- else if (itsofar(ivx)/lenbar .gt. nbb4) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'This note spans a bar line!')
- call stop1()
- end if
- if (idotform.eq.1 .or. idotform.eq.3) then
- call g1etchar(lineq,iccount,charq)
- if (index('abcedfgr',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected note name or "r" here!')
- call stop1()
- end if
- idotform = idotform+1
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
- call g1etchar(lineq,iccount,charq)
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected chord note name here!')
- call stop1()
- end if
-25 call g1etchar(lineq,iccount,durq)
-c if (index('dre12345678',durq) .gt. 0) then
- if (index('dre12345678c',durq) .gt. 0) then
- go to 25
- else if (index('fsn',durq) .gt. 0) then
-c
-c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so
-c MUST come right after "f,s,n"
-c
- if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1
- go to 25
- else if (durq .eq. 'A') then
- if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n" before "A" in chord note!')
- call stop1()
- end if
- go to 25
- else if (index('<>',durq) .gt. 0) then
- if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then
-c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Must have "f,s,n,A" before "<" or ">"!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('1234567890.',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here for accidental shift!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (index('+-',durq) .gt. 0) then
- if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0)
- * go to 25
-c
-c Number or '.' (durq) follows +/- . Get it.
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.' .and. index('1234567890',
- * lineq(iccount+1:iccount+1)) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"." here must be followed by a digit!')
- call stop1()
- else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Number after +/- must follow "d,s,f,n,A"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (index('+-',durq) .eq. 0) then
- iccount = iccount-1
- go to 25
- end if
-c
-c 2nd +/-
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '.') call g1etchar(lineq,iccount,durq)
- if (index('1234567890',durq) .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 25
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in chord note!')
- call stop1()
- end if
- else if (charq .eq. 'G') then
- ngr = 1
-9 call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- ngr = nint(fnum)
- iccount = iccount-1
- go to 9
- else if (index('AWulxs',charq) .gt. 0) then
- go to 9
- else if (charq .eq. 'm') then
- call g1etchar(lineq,iccount,charq)
- if (index('01234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit less than 5 must follow "m" in a grace note!')
- call stop1()
- end if
- go to 9
- else if (charq .eq. 'X') then
-c
-c Space before main note
-c
- call g1etchar(lineq,iccount,charq)
- if (index('0123456789.',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 9
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A number must follow "X" in a grace note!')
- call stop1()
- end if
- end if
-c
-c At this point, charq is first note name in rest (grace?)
-c
- do 19 igr = 1 , ngr
- numnum = 0
- if (igr .gt. 1) then
-55 call g1etchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- end if
- if (index('abcdefg',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In grace, expected "a"-"g"!')
- call stop1()
- end if
-18 call g1etchar(lineq,iccount,charq)
- if (charq .ne. ' ') then
- if (index('1234567',charq) .gt. 0) then
- if (numnum .eq. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one of "+-1234567" allowed here in grace!')
- call stop1()
- end if
- numnum = 1
- go to 18
-c else if (index('nfs',charq) .gt. 0) then
- else if (index('+-nfs',charq) .gt. 0) then
- go to 18
- end if
-c
-c Digits are possible octave numbers
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after note name in grace!')
- call stop1()
- end if
-19 continue
- else if (charq .eq. chax(92)) then
- call chklit(lineq,iccount,literr)
- if (literr .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * literq(literr))
- call stop1()
- end if
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. "o" symbol must come AFTER the affected note
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"o" must be in same input block, after affected note!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal ornament!')
- call stop1()
- end if
- if (dumq .eq. ':') then
- call g1etchar(lineq,iccount,dumq)
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after "o:"!')
- call stop1()
- else if (.not.ornrpt) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Turned off repeated ornaments before they were on!')
- call stop1()
- end if
- ornrpt = .false.
- else if (dumq .eq. 'g') then
- if (issegno) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry, only one "segno" per input block!')
- call stop1()
- else if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'segno can only be in voice 1!')
- call stop1()
- end if
- issegno = .true.
-12 call g1etchar(lineq,iccount,dumq)
- if (dumq.eq.'-' .or.
- * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12
- if (dumq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in segno ornament symbol!')
- call stop1()
- end if
- else if (dumq .eq. 'T') then
-c
-c Trill. may be followed by 't' and/or number. read 'til blank
-c
-22 call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected blank after ":"!')
- call stop1()
- end if
- go to 32
- else if (dumq .ne. ' ') then
- go to 22
- end if
- else if (dumq .eq. 'f') then
- call g1etchar(lineq,iccount,dumq)
- if (index(' d+-:',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "f" in fermata ornament symbol!')
- call stop1()
- end if
- if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. ':') go to 32
- else if (dumq .eq. 'e') then
- call g1etchar(lineq,iccount,dumq)
- if (index('sfn?',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "e" in edit. accid. symbol!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
- else
- call g1etchar(lineq,iccount,dumq)
- end if
- if (index('+- :',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in ornament symbol!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be an integer here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (durq .eq. ':') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot shift AND repeat an ornament!')
- call stop1()
- end if
-c
-c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes.
-c
- if (index('+-',durq) .gt. 0) then
- if (index('.0123456789',lineq(iccount+1:iccount+1))
- * .eq. 0) then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'There should be a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- end if
- end if
-32 continue
- if (dumq .eq. ':') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '":" must be followed by blank in "o: "!')
- call stop1()
- else if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Turned on repeated ornaments but already on!')
- call stop1()
- end if
- ornrpt = .true.
- end if
- else if (index('st(){}',charq) .gt. 0) then
- numint = 0
- iposn = 0
-8 call g1etchar(lineq,iccount,dumq)
- iposn = iposn+1
- if (charq.eq.'t' .and. dumq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot use "t" as an option on a tie!')
- call stop1()
- end if
- if (index('udltb+-fnhHps ',dumq) .eq. 0) then
-c
-c Check for explicit ID code.
-c
- ic = ichar(dumq)
- if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or.
- * ic.gt.90) then
-c
-c Not 0-9 or A-Z, so exit
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in slur symbol!')
- call stop1()
- else
-c
-c It is a possible ID code. Right place?
-c
- if (iposn .ne. 1) then
-c
-c Slur ID is not 2nd!
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID must be second character in slur symbol!')
- call stop1()
- else if (charq.eq.'t' .and. fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur ID not allowed on non-postscript tie!')
- call stop1()
- end if
- end if
-c
-c Slur ID is OK. Note it cannot be "H" at this point..
-c
- go to 8
- else if (dumq .eq. 'H') then
- if (iposn .eq. 1) go to 8
-c
-c "H" is NOT an ID code.
-c
- if (.not.fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- end if
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount=iccount+1
- iposn = iposn+1
- end if
- go to 8
- else if (index('fh',dumq).gt.0 .and. .not.fontslur
- * .and. charq.eq.'t') then
-c
-c 3/9/03 Can't reshape postscript tie.
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot reshape postscript ties this way!')
- call stop1()
- else if (dumq .eq. 'p') then
-c
-c local change in postscript slur/tie adjustment default
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must use postscript slurs ("Ap") to use this option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" here!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('st',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "s" or "t" here!')
- call stop1()
- end if
- iposn = iposn+2
- go to 8
- end if
- if (index('udltbfnh',dumq) .gt. 0) then
- go to 8
- else if (index('+-',dumq) .gt. 0) then
- numint = numint+1
- if (fontslur .and. charq.eq.'t') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+|-" for slur height only allowed in "s"-slurs!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (numint .eq. 1) then
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- else if (numint .eq. 2) then
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- else
-c
-c Third signed integer, must be a midslur or curve spec.
-c
- if (abs(fnum).gt.31) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur midheight must be in the range (-31,31)!')
- call stop1()
- end if
- if (durq .eq. ':') then
-c
-c Expecting curve parameters. Get two numbers
-c
- do 41 i = 1 , 2
- iccount = iccount+1
- fnum = ichar(lineq(iccount:iccount))-48
- if (abs(fnum-3.5) .gt. 3.6) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Slur curve parameter must be in range (0,7)!')
- call stop1()
- end if
-41 continue
- iccount = iccount+1
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 's') then
-c
-c What follows should be one or two signed numbers for adjustment of line break
-c slur, end of 1st segment or start of second.
-c
- if (fontslur) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not use linebreak slur options with font-based slurs!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,dumq)
- if (index('+-',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character must be "+" or "-"!')
- call stop1()
- end if
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (nint(fnum) .gt. 30) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Magnitude of slur height adjustment cannot exceed 30!')
- call stop1()
- end if
- if (index('+-',dumq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (abs(fnum) .gt. 6.3) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Slur horiz shift must be in range (-6.3,6.3)!')
- call stop1()
- end if
- end if
- iccount = iccount-1
- go to 8
- else if (dumq .eq. 'H' .and. iposn.gt.1) then
- if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1
- go to 8
- end if
- else if (charq .eq. '?') then
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
- if (durq .ne. '-') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting "-"!')
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expecting number!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- end if
- else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
- * index('#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
- if (itsofar(ivx).eq.0 .and.
- * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then
-c
-c Figure before first note in block
-c
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot put figure before first note in block!')
- call stop1()
- end if
- if (charq.eq.'x') then
- indxb = index(lineq(iccount:128),' ')
- if (indxb .lt. 5) then
- call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot have a blank here in floating figure!')
- call stop1()
- end if
- end if
- if (usefig) ifig = 1
-5 call g1etchar(lineq,iccount,charq)
- if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in figure!')
- call stop1()
- else if (charq .eq. '+') then
-c
-c vertical offset, must be integer, then blank
-c
- call g1etchar(lineq,iccount,charq)
- if (index('123456789',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer for vertical offset expected here!')
- call stop1()
- end if
- call readnum(lineq,iccount,charq,fnum)
- if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Vertical offset must terminate figure!')
- call stop1()
- end if
- iccount = iccount-1
- go to 5
- else if (charq .eq. 's') then
- isligfont = .true.
- end if
- if (charq .ne. ' ') go to 5
- else if (charq .eq. '[') then
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Started forced beam while another was open!')
- call stop1()
- end if
- fbon = .true.
-17 call g1etchar(lineq,iccount,charq)
- if (index('uljhf:',charq) .gt. 0) then
- go to 17
- else if (index('+-',charq) .gt. 0) then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- go to 17
- else if (charq .eq. 'm') then
-c
-c Forced multiplicity, next char should be 1-4
-c
- call g1etchar(lineq,iccount,charq)
- if (index('1234',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!')
- call stop1()
- end if
- go to 17
- else if (charq .ne. ' ') then
- if (index('0123456789',charq) .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "[", digits must now be preceeded by "+" or "-"!')
- print*,'You will have to edit older sources to meet this rqmt,'
- print*,'but it was needed to allow 2-digit height adjustments.'
- print*,'Sorry for the inconvenience. --The Management'
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after [!')
- end if
- call stop1()
- end if
- else if (charq .eq. ']') then
- if (.not.fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced beam stop with no corresponding start!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,charq)
- if (charq .eq. '-') then
- if (lineq(iccount+1:iccount+2) .ne. '[ ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'Only sequence allowed here is "[ "!')
- call stop1()
- else
- iccount = iccount+2
- end if
- else if (charq .eq. '[') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else
-c
-c Forced beam is really ending
-c
- fbon = .false.
- if (charq .eq. 'j') then
- if (lineq(iccount+1:iccount+1) .ne. ' ') then
- call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1,
- * 'This character must be a blank!')
- call stop1()
- end if
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"]" must be followed by blank, "j", "-", or "["!')
- call stop1()
- end if
- end if
- else if (charq .eq. 'D') then
-c
-c Dynamic mark
-c
- if (nnl(ivx) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"D" must not come before any notes have been entered!')
- call stop1()
- end if
- call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
- else if (index('lhw',charq) .gt. 0) then
-c
-c Save position for later check
-c
- icclhw = iccount
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789.+- ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "l", "w", or "h"!')
- call stop1()
- end if
- isheadr = isheadr .or. charq .eq. 'h'
- if (index(' +-',durq) .gt. 0) then
-c
-c There is a header (or lower string?)
-c
- if (index('+-',durq) .gt. 0) then
-c
-c User-defined vert offset (\internote).
-c
- if (charq .ne. 'h') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"+" or "-" not permitted here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- . Check for digit.
-c Can blow durq since not using fnum for now, but...
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a digit here!')
- call stop1()
- end if
-c
-c Have "h" followed by +/- followed by a digit. No need to get the number.
-c
-c call readnum(lineq,iccount,durq,fnum)
- end if
- if (charq .ne. 'w') then
-c
-c Header or lower string.
-c
- if (icclhw .ne. 1) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * '"h" or "l" must be first character in line!')
- call stop1()
- end if
-c
-c Read past the next line, which has the string.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol "w" (width) must be followed by a digit!')
- call stop1()
- end if
- else
-c
-c Height or width change spec. Check if at start of piece.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Symbol must go at top of first input block!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,dimen)
-c
-c Check units. Convert to points
-c
- if (durq .eq. ' ' .or. durq .eq. 'p') then
- dimen = dimen+.5
- else if (durq .eq. 'i') then
- dimen = dimen*72+.5
- else if (durq .eq. 'm') then
- dimen = dimen/25.4*72+.5
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal unit; must be "p","i",or"m"!')
- call stop1()
- end if
- if (charq .eq. 'h') then
- ptheight = int(dimen)
- else
- widthpt = int(dimen)
- end if
- end if
- else if (charq .eq. 'm') then
-c
-c Time signature change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Meter change only OK in voice 1, at start of block!')
- print*,'voice number is',ivx
- call stop1()
- end if
- newmeter = .true.
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- if (mtrnuml .eq. 0) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Digit 0 not allowed here!')
- call stop1()
-c else if (mtrdenl .eq. 1) then
-cc
-cc Kluge!!!
-cc
-c mtrdenl = 2
-c mtrnuml = 2*mtrnuml
- end if
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
-c
-c Read past printed time signature; not used in pmxa.
-c
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbar = lenmult*mtrnuml*lenbeat
- mtrnuml = 0
- else if (charq .eq. 'C') then
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
-c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then
- * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!')
- * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!')
- call stop1()
- end if
- gotclef = .true.
- else if (charq .eq. 'R') then
- if (ivx .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Repeats can only go in voice 1!')
- call stop1()
- end if
-10 call g1etchar(lineq,iccount,durq)
- if (index('lrdDbz',durq) .gt. 0) go to 10
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "R" (repeat/double bar)!')
- call stop1()
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- if (iv .ne. 1) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Voltas are only allowed in voice #1!')
- call stop1()
- else if (isvolt) then
- print*
- print*,'*******WARNING********'
- write(15,'(/,a)')'*******WARNING********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There is more than one volta in this input block.!')
- print*,'This may work in a score, but WILL NOT work in parts.'
- print*,
- *'Safest to have only 1 volta per block, at the start of the block'
- write(15,'(a)')
- * 'This may work in a score, but WILL NOT work in parts.'
- write(15,'(a)')
- *'Safest to have only 1 volta per block, at the start of the block'
- end if
- isvolt = .true.
- lvoltxt = 0
-11 call g1etchar(lineq,iccount,durq)
- if (durq .ne.' ') then
- go to 11
- end if
- else if (charq .eq. 'B') then
- continue
- else if (charq .eq. 'P') then
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only allowed at beginning of block!')
- call stop1()
- end if
-16 call g1etchar(lineq,iccount,durq)
- if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and.
- * ichar(durq).le.57)) go to 16
- if (durq .eq. 'c') then
-c
-c Expect a centered name, and it has to be last option
-c
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. '"') then
-c
-c Quoted name, go to next quote mark
-c
- do 35 iccount = iccount+1 , 127
- if (lineq(iccount:iccount) .eq. '"') go to 36
-35 continue
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Missing close quote after page number command (P)!')
- call stop1()
-36 continue
- else if (durq .ne. ' ') then
-c
-c Space-delimited name, look for next blank
-c
- do 37 iccount = iccount+1 , 127
- if (lineq(iccount:iccount) .eq. ' ') go to 38
-37 continue
-38 continue
- end if
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only "l","r","c" or digit allowed after "P"!')
- call stop1()
- end if
- else if (charq .eq. 'W') then
- call g1etchar(lineq,iccount,durq)
- if (index('.0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number to start here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1))
- else if (charq .eq. 'T') then
-c
-c Titles
-c
- call g1etchar(lineq,iccount,durq)
- if (index('itc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must put "i", "t", or "c" after "T"!')
- call stop1()
- end if
- ihead = ihead+2**(index('itc',durq)-1)
-c
-c Maybe a number after 'Tt', but ignore here. Read past string on next line.
-c
- call read10(charq,lastchar)
- nline = nline+1
- iccount = 128
- else if (charq .eq. 'A') then
-27 call g1etchar(lineq,iccount,durq)
- if (index('rbsdeK',durq) .gt. 0) then
- go to 27
- else if (durq .eq. 'v') then
- if (ibarcnt .eq. 0) novshrinktop = .true.
- go to 27
- else if (durq .eq. 'a') then
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fbar)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'i') then
- call g1etchar(lineq,iccount,durq)
-c
-c Local interstaff correction. Set to -1. if not specifiec, or after use,
-c or anytime except at top, since pmxb handles all times except at top.
-c
- call readnum(lineq,iccount,durq,tintstf)
- if (ibarcnt .eq. 0) fintstf = tintstf
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'I') then
-c
-c Global interstaff correction. Use in place of fintstf if fintstf<0
-c
- call g1etchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- go to 27
- else if (durq .eq. 'o') then
- optimize = .true.
- go to 27
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , nv
- call g1etchar(lineq,iccount,durq)
- if (index('-0st',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'After "AS", need nv instances of "s,t,-,0"!')
- call stop1()
- end if
- if (durq.eq.'-'.or.durq.eq.'s') then
- isize(iiv) = 1
- else if (durq.eq.'t') then
- isize(iiv) = 2
- end if
-50 continue
- go to 27
- else if (durq .eq. 'p') then
- fontslur = .false.
-42 continue
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,durq)
- if (index('shtc',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only letters allowed here are "s","h","t","c"!')
- call stop1()
- end if
-c
-c Now check for another default modifier
-c
- go to 42
- else if (index('lh',durq) .gt. 0) then
-c
-c Flags for optional linebreak ties or header specials
-c
- go to 42
- else
- iccount = iccount-1
- end if
- go to 27
- else if (durq .eq. 'N') then
-c
-c Override default name for a part file. Must have part number, then
-c partname in quotes. Must be on line by itself, and start in column 1.
-c Will only be passed thru to scor2prt.
-c
- if (iccount .ne. 2) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must start in column 1!')
- call stop1()
- end if
- ndxquote = index(lineq,'"')
- if (ndxquote.lt.4 .or. ndxquote.gt.5 .or.
- * index('123456789',lineq(3:3)).eq.0 .or.
- * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"AN" must be followed by inst. #, then quote!')
- call stop1()
- end if
- ndxquote = index(lineq(ndxquote+1:128),'"')
- if (ndxquote .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'In "AN", file name must be in quotes!')
- call stop1()
- end if
- iccount = 128
- else if (durq .eq. 'T') then
- cstuplet = .true.
- else if (durq .eq. 'R') then
-c
-c Get full name of normal include file; must occupy remainder of line
-c
- call getpmxmod(.false.,lineq(iccount+1:128))
- iccount = 128
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'After "A" must follow one of the letters abdeiINprsST!')
- * 'After "A" must follow one of the letters abdeiINprRsST!')
- call stop1()
- end if
- else if (charq .eq. 'K') then
-c
-c Rules and function of K command
-c
-c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is
-c initial sig, and must be passed to pmxb because it is needed when topfile
-c is called, which is before the K+n+m command is read in pmxb. Also, we
-c compute and save ibrkch and newkey for each syst, accounting for key changes,
-c then adjust fbar to make poenom much more accurate.
-c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('+-i',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"K" (transpose or key change) must be followed by "+,-,i"!')
- call stop1()
- end if
- if (durq .ne. 'i') then
-c
-c Normal key change and/or transposition)
-c
-c iccount = iccount+1
- num1 = 44-ichar(durq)
-c
-c num1= +1 or -1
-c
- ztrans = num1.eq.-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st +/- must be followed by a number!')
- call stop1()
- end if
-c iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = nint(fnum)*num1
- ztrans = ztrans .and. num1.eq.0
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st number after "K" must be followed by "+,-"!')
- call stop1()
- end if
- iccount = iccount+1
- num2 = 44-ichar(durq)
- call readnum(lineq,iccount,durq,fnum)
- num2 = num2*int(fnum+.1)
- if (num1.eq.0 .and. .not.ztrans) then
-c
-c Key change, only one per block allowed
-c
- if (iskchb) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Only one key change allowed per input block!')
- call stop1()
- end if
- iskchb = .true.
- nkeys = nkeys+1
- kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0
-c
-c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak.
-c
- ibrkch(nkeys) = ibarcnt+nbars
- if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1
- newkey(nkeys) = num2+idsig
- else
-c
-c Transposition
-c
- fulltrans = .true.
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Transposition must be at top of first input block!')
- call stop1()
- end if
- isig1 = num2
- idsig = isig1-newkey(1)
-c
-c idsig is the difference between sig after transposition, and sig in setup.
-c It may alter # of accid's in key changes if there is transposition.
-c
- end if
- else ! durq='i'
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here;
-c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
-c if (fulltrans) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Cannot yet combine full and instrument transposition!')
-c call stop1()
-c end if
- call GetiTransInfo(.true.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
- end if
- else if (charq .eq. '|') then
-c
-c Optional bar symbol
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar line marker out of place!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- end if
- else if (charq .eq. '/') then
- if (ornrpt) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with repeated ornament still on!')
- ornrpt = .false.
- end if
- if (stickyS) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'WARNING: Block ended with sticky stemshrink still on!')
- stickyS = .false.
- end if
- if (fbon) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block ended with forced beam open!')
- call stop1()
- else if (shifton) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Bar ended with user-defined shift still on!')
- call stop1()
- else if (gotclef) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'May not enter clef at end of input block!')
- call stop1()
- end if
- barend = .false.
-c
-c Perform time checks
-c
- if (mod(itsofar(ivx),lenbar).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not divisible by lenbar!')
- print*,'lenbar is ',lenbar
- call stop1()
- else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then
- print*
- print*,'# of bars in voice 1, current voice:',
- * itsofar(1)/lenbar,itsofar(ivx)/lenbar
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Block duration not equal to voice 1!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new voice
-c
- if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New voice is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c New voice is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- if (ivx .gt. nm) then
- write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm,
- * ' lines of music at once'
- call stop1()
- end if
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- do 24 j = 1 , 200
- rest(ivx,j) = .false.
- nacc(ivx,j) = 0
-24 continue
-c
-c For midi stuff, record that there is a 2nd line of music in this voice
-c
- if (ismidi) twoline(iv) = .true.
- end if
- end if
- iccount = 128
- else if (charq .eq. 'S') then
-c
-c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs.
-c
- if (ibarcnt .gt. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"S" can only be in first input block!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'A digit must follow "S"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- nsyst = nint(fnsyst)
-14 continue
- if (durq .eq. 'P') then
-c
-c New npages for parts.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- npages = nint(fnsyst)
- go to 14
- else if (durq .eq. 'm') then
-c
-c Reset musize (musicsize).
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789 ',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnsyst)
- musize = nint(fnsyst)
- wheadpt = whead20*musize
- go to 14
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in "S" symbol!')
- call stop1()
- end if
- else if (charq .eq. 'L') then
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+nbars+1
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced line break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,sysflb)
- isysflb(nflb) = nint(sysflb)
- if (nflb .gt. 1) then
-c
-c Check if new number is > prior one
-c
- if (isysflb(nflb) .le. isysflb(nflb-1)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You already forced a line break at a later line!')
- call stop1()
- end if
- end if
- if (npages .eq. 0) then
- print*
- print*,'WARNING! You forced a line break at line ',
- * isysflb(nflb),' but npage = 0. Continue?'
- read(*,'(a)') charq
- if (index('yY',charq) .eq. 0) call stop1()
- else if (isysflb(nflb) .gt. nsyst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Forced line break at line num > nsyst!')
- call stop1()
- else if (index(' PM',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have " ", "P", or "M" here!')
- call stop1()
- end if
- if (durq .eq. 'P') then
-c
-c Forced page break here, get page number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Need integer to define forced page break!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- nfpb = nfpb+1
- ipagfpb(nfpb) = nint(fnum)
- isysfpb(nfpb) = isysflb(nflb)
- if (ipagfpb(nfpb) .gt. npages) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break at page num > npages!')
- call stop1()
- else if (nfpb .gt. 1) then
- if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Forced page break numbers must increase!')
- call stop1()
- end if
- end if
- end if
- if (index(' M',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in linebreak symbol!')
- call stop1()
- else if (durq .eq. 'M') then
- nmovbrk = nmovbrk+1
- isysmb(nmovbrk) = isysflb(nflb)
- call g1etchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Vertical spacing, read past number.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Integer required here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- go to 31
- else if (durq .eq. 'i') then
-c
-c Change indentation,
-c
- call g1etchar(lineq,iccount,durq)
- if (index('.123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Decimal number required here!')
- call stop1()
- end if
-c
-c fracsys was initialized in block data to all 0.'s
-c
- call readnum(lineq,iccount,durq,fracsys(nmovbrk))
- go to 31
- else if (durq .eq. 'c') then
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
- call g1etchar(lineq,iccount,durq)
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have "+" or "-" after "r" as movement break option!')
- call stop1()
- end if
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iorig in original list of instruments.
-c
- nv = 0
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number, get next two characters
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
-c
-c durq is a single digit number for noinow
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal new number of instruments '//durq//
- * ' at movement break!')
- call stop1()
- end if
- ninow = ichar(durq)-48
- end if
- if (ninow.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New number of instruments must be <= original!')
- call stop1()
- end if
- do 63 iinow = 1 , ninow
- call g1etchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c Signals a 2-digit number
-c
- call g1etchar(lineq,iccount,durq)
- call g1etchar(lineq,iccount,dumq)
- if (index('12',durq).eq.0
- * .or.index('0123456789',dumq).eq.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal 2-digit instrument number '//durq//dumq//
- * ' at movement break!')
- call stop1()
- end if
- read(lineq(iccount-1:iccount),'(i2)')iorig
- else
-c
-c durq is a single digit number for iorig
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal instrument number '//durq//
- * ' at movement break!')
- call stop1()
- end if
- iorig = ichar(durq)-48
- end if
- if (iorig .gt. noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'New instrument number must be <= original noinst!')
- call stop1()
- end if
- nv = nv+nsperi(iorig)
-63 continue
- do 61 iiv = 1 , nv
-c
-c Get clef names
-c
- call g1etchar(lineq,iccount,durq)
- if (.not.(index('tsmanrbf',durq).gt.0 .or.
- * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!')
- call stop1()
- end if
-c
-c Initialize new voices
-c
- nvmx(iiv) = 1
- ivmx(iiv,1) = iiv
- itsofar(iiv) = 0
- nnl(iiv) = 0
- do 62 j = 1 , 200
- rest(iiv,j) = .false.
-62 continue
-61 continue
-c
-c Loop back up, this might not be last option in M
-c
- call g1etchar(lineq,iccount,durq)
- go to 31
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after Movement break symbol!')
- call stop1()
- end if
- if (fracsys(nmovbrk) .lt. 0.001) then
-c
-c Since fracsys was not explicitly set, set it to prior value.
-c
- if (nmovbrk .eq. 1) then
- fracsys(nmovbrk) = fracindent
- else
- fracsys(nmovbrk) = fracsys(nmovbrk-1)
- end if
- end if
- end if
-c
-c Just before exiting if-block for forced line breaks, set counter to use when
-c dealing with vertical space calcs
-c
- nistaff(nflb) = nv-1
- else if (charq .eq. 'F') then
- usefig = .false.
- else if (charq .eq. 'X') then
- call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1,
- * udsp(ibarcnt+nbars+1),wheadpt)
- else if (charq .eq. 'I') then
-c
-c MIDI settings.
-c
- if (ivx.ne.1 .or. nnl(1).ne.0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MIDI stuff only allowed at start of block!')
- call stop1()
- end if
- if (nv .gt. 15) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Sorry but MIDI does not work with more than 15 voices!')
- call stop1()
- end if
- ismidi = .true.
- call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,.true.)
- else if (charq .eq. 'M') then
- call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx,
- * nline)
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- else
- print*,'ASCII code:',ichar(charq)
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'This character is not allowed here!')
- print*,'ASCII code:',ichar(charq)
- call stop1()
- end if
- return
- end
- subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey,npages,nsyst,musize,bottreb)
- parameter(nm=24,maxblks=4000)
- character*65536 bufq
- character*1 chax
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*128 lineq
- logical lastchar,issegno,isheadr,isvolt,fbon,bottreb,
- * newway
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
-c
-c Get the first line
-c
- iccount = 0
- nline = 1
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') then
- nline = nline+1
- go to 9
- end if
- if (lineq(1:3) .eq. '---') then
-c
-c Have TeX input until next line that starts with '---'
-c
-3 nline = nline+1
- call getbuf(lineq)
- if (ilbuf .gt. nlbuf) go to 1
- go to 2
-1 print*,'You did not terminate type 0 TeX input with "---"'
- call stop1()
-2 continue
- if (lineq(1:3) .ne. '---') go to 3
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq and nline are first non-TeX lines.
-c
- nv = nint(readin(lineq,iccount,nline))
- if (nv .gt. nm) then
- write(*,'(1x,a46,i3)')
- * 'In setup data, number of voices cannot exceed',nm
- call stop1()
- end if
- noinst = nint(readin(lineq,iccount,nline))
- if (noinst .gt. nv) then
- write(*,'(a)')
- * 'In setup data, cannot have more instruments than staves'
- call stop1()
- end if
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 10 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
-10 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge!!!
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then
- write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8'
- call stop1()
- end if
- xmtrnum0 = readin(lineq,iccount,nline)
- newkey = nint(readin(lineq,iccount,nline))
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
- if (fracindent .ge. 1.) then
- write(*,'(a)')'In setup data, fracindent must be <1'
- call stop1()
- end if
- if (npages .gt. nsyst) then
- print*,'Error in input file: npages > nsyst'
- call stop1()
- else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then
- call printl('Musicsize must be 16, 20, 24, or 29')
- call stop1()
- end if
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , abs(noinst)
-5 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 5
-4 continue
-c
-c Mext non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 6
- do 7 iv = 1 , nv
-c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then
- if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then
- call errmsg(lineq,iv,0,
- * 'There should be a clef symbol here!')
- call stop1()
- end if
-7 continue
- if (lineq(nv+1:nv+1) .ne. ' ') then
- call errmsg(lineq,nv+1,0,
- * 'There should be a blank here!')
- call stop1()
- end if
-c
-c Set flag if voice 1 is treble, since it affects vertical spacing
-c
- bottreb = lineq(1:1).eq.'t'
-c
-c Mext non-comment line has path name
-c
-8 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 8
- lpath = index(lineq,' ')-1
- if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then
- call errmsg(lineq,lpath,0,
- * 'Last character of pathname is not "/",":", or "'
- * //chax(92)//'"!')
- call stop1()
- end if
- return
- end
- subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c
- logical notxtup,shifton,number,btest
- character*128 lineq
- character*1 charq,dumq
- number = .false.
- nPBSc = 0
-1 call g1etchar(lineq,iccount,charq)
- if (index('PBS:',charq) .gt. 0) then
-c
-c Continue checking here even if "P".
-c
- ipbsc = index('PBS:',charq)
- if (btest(nPBSc,ipbsc)) then
- call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!')
- call stop1()
-c else if (.not.notxtup .and. ipbsc.gt.2) then
-c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!')
-c call stop1()
- end if
- nPBSc = ibset(nPBSc,ipbsc)
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (index('+-',charq) .gt. 0) then
- call g1etchar(lineq,iccount,dumq)
- if (index('.0123456789',dumq) .eq. 0) then
- call errmsg(lineq,iccount,ibar,'Expected a number here!')
- call stop1()
- end if
- end if
- call readnum(lineq,iccount,dumq,fnum)
- if (charq.eq.'-') fnum = -fnum
- if (dumq .ne. 'p') then
- iccount = iccount-1
- fnum = fnum*wheadpt
- end if
- go to 1
- else if (charq .ne. ' ') then
- call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!')
- call stop1()
- end if
-c
-c Done with parsing. Other checks
-c
- if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Cannot have both "P" and "B" or "S" and ":"!')
- call stop1()
- end if
- if (btest(nPBSc,4)) then
- if (number) then
- if (shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Started a group shift without stopping prior one!')
- call stop1()
- else
- shifton = .true.
- end if
- else
- if (.not. shifton) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Ended a group shift without starting one!')
- call stop1()
- else
- shifton = .false.
- end if
- end if
- end if
-c
-c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst)
-c
- if (iand(nPBSc,26).eq.0) udsp = udsp+fnum
- if (.not.number .and. .not.btest(nPBSc,4)) then
- call errmsg(lineq,iccount-1,ibar,
- * 'Must have either a number or a colon in "X" symbol!')
- call stop1()
- end if
- return
- end
-c integer*4 function mytime()
-c CHARACTER(10) tq
-c CALL DATE_AND_TIME(TIME=tq)
-c read(tq,'(2i2,f6.3)')ih,im,ts
-c mytime = 1000*(ts+60*(im+60*ih))
-c return
-c end
- subroutine getbuf(lineq)
- parameter (maxblks=4000)
- character*(*) lineq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf))
- ipbuf = ipbuf+lbuf(ilbuf)
- ilbuf = ilbuf+1
- return
- end
- subroutine getchar(lineq,iccount,charq)
- parameter (nm=24)
-c
-c Gets the next character out of lineq*128. If pointer iccount=128 on entry,
-c then reads in a new line. Resets iccount. Ends program if no more input.
-c
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,equalize,stickyS
- character*1 charq,rptfq1,rptfq2
- character*128 lineq,lnholdq
- if (iccount .eq. 128) then
- call read10(lineq,lastchar)
- if (lastchar) return
- if (.not. endmac) then
- iccount = 0
- else
- endmac = .false.
- iccount = icchold
- lineq = lnholdq
- end if
- if (mrecord) then
- call mrec1(lineq,iccount,ndxm)
- end if
- end if
- iccount = iccount+1
- charq = lineq(iccount:iccount)
- return
-999 continue
- lastchar = .true.
- return
- end
- subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount)
- parameter (nm=24)
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical fontslur,upslur,WrotePsslurDefaults
- character*1 durq,chax
- character*4 dynsymq
- character*128 lineq
-c
-c Get info for dynamic mark. Enter after getting "D", iccount sits on "D"
-c Bits in idyndat are as follows
-c 00-03 ivx
-c 04-11 ip
-c 12-15 code for type of mark
-c 0 => arbitrary text
-c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff
-c If (.not. fontslur)
-c 13 => hairpin start, 14,15 => <,> (ending)
-c else
-c 13 < start, 14 > start, 15 ending
-c end if
-c 16 flag for vertical offset
-c 17-23 vertical offset + 64 , \internote
-c 31 Hairpin start (0), stop (1)
-c
-c idynda2
-c
-c 00 flag for horizontal offset
-c 01-09 (horizontal offset)/10 + 25.6 notehead widths
-c 10 5th bit for ivx (5/15/10)
-c
- irest = ibset(irest,26)
- ndyn = ndyn+1
- idyn = ivx
- idynda2(ndyn) = 0
- if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1)
- call setbits(idyn,8,4,ip)
- if (lineq(iccount+1:iccount+1) .eq. '"') then
-c
-c text-dynamic
-c
- ntxtdyn = ntxtdyn+1
- iend = iccount+index(lineq(iccount+2:128),'"')+2
- txtdynq(ntxtdyn) = lineq(iccount+2:iend-2)
-c
-cc Store ivx, ip in bits 0-11
-c Store ivx, ip in bits 0-12
-c
-c ivxiptxt(ntxtdyn) = idyn
- ivxiptxt(ntxtdyn) = ivx+32*ip
- ipm = index('- +',lineq(iend:iend))
- idno = 0
- else
-c
-c Word-group or hairpin
-c
- do 1 iend = iccount+2 , 128
- ipm = index('- +',lineq(iend:iend))
-c
-c Exit the loop at first blank, "+", or "-"
-c
- if (ipm .gt. 0) go to 2
-1 continue
-2 continue
- read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
- * dynsymq
- idno = (index(
- * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ',
- * dynsymq)+3)/4
-c
-c Save for later down
-c
- idno1 = idno
- end if
-c
-c Set flag to check level later if in beam
-c
- iornq = ibset(iornq,23)
- if (idno.ge.14) then
-c
-c Hairpin here. Check if opposite type from one that's already on
-c
- if (idno.eq.14.and.btest(listdecresc,ivx) .or.
- * idno.eq.15.and.btest(listcresc,ivx)) then
- call printl(' ')
- call printl('Started one kind of hairpin while other is on')
- call stop1()
- end if
-c
-c Start or stop?
-c
- if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then
-c
-c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is.
-c
- if (.not.fontslur) idno = 15
- else if (fontslur) then
-c
-c Start of font slur
-c
- idno = 13
- else
-c
-c Start of postscript slur
-c
- idno = idno-1
- end if
- end if
-c
-c Now that we used list[de]cresc, update
-c
- if (idno .ge.13) then
- if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then
-c
-c Something's ending
-c
- if (btest(listcresc,ivx)) then
-c
-c It's a cresc!
-c
- listcresc = ibclr(listcresc,ivx)
- else
- listdecresc = ibclr(listdecresc,ivx)
- end if
- else
-c
-c Something's starting
-c
- if (idno1 .eq. 14) then
-c
-c It's a cresc!
-c
- listcresc = ibset(listcresc,ivx)
- else
- listdecresc = ibset(listdecresc,ivx)
- end if
- end if
- end if
- call setbits(idyn,4,12,idno)
- iccount = iend
- if (ipm .ne. 2) then
-c
-c There is a vertical shift
-c
- idyn = ibset(idyn,16)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(fnum)
- call setbits(idyn,7,17,(ipm-2)*idno+64)
- ipm = index('- +',durq)
- if (ipm .ne. 2) then
-c
-c There is a horizontal shift
-c
-c idynda2(ndyn) = ibset(idyn,23)
- idynda2(ndyn) = ibset(idynda2(ndyn),0)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- idno = nint(10*fnum)
- call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256)
- end if
-c
-c iccount should be on the blank at the end of the entire symbol
-c
- end if
- idyndat(ndyn) = idyn
- return
- end
- subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig,
- * itsofar,nodur,figq,ivupfig,nfigs)
- logical isfig
- character*1 charq
- character*10 figq
- character*128 lineq
-c
-c As of 11/26/08, trapped extra figures in getnote, so no need here.
-c
-c if (ivx .gt. 2) then
-cc
-cc Read past the figure
-cc
-c6 call getchar(lineq,iccount,charq)
-c if (charq .ne. ' ') go to 6
-c return
-c end if
- nfigs = nfigs+1
- ivupfig = 0
- itoff = 0
- if (charq .eq. 'x') then
-c
-c Floating figure.
-c
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')noff
- call getchar(lineq,iccount,charq)
- read(charq,'(i1)')loff
- itoff = noff*ifnodur(loff,'x')
- call getchar(lineq,iccount,charq)
- else
-c
-c Figure on a note
-c
- isfig = .true.
- end if
- itfig = itsofar+itoff-nodur
- lfig = 1
- figq = charq
-5 call getchar(lineq,iccount,charq)
-c if (charq .ne. ' ') then
- if (index(' +',charq) .eq. 0) then
- figq = figq(1:lfig)//charq
- lfig = lfig+1
- go to 5
- else if (charq .eq. '+') then
-c
-c Get vertical offset for figure. Next character after number has to be blank.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ivupfig = nint(fnum)
- end if
- return
- end
- subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- parameter (nm=24)
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg
- character*1 charq,durq
- character*20 voltxtq
- character*128 lineq,litq
- integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm),
- * ndlev(nm,2)
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
- ngrace = ngrace+1
- ivg(ngrace) = ivx
- ipg(ngrace) = nnl(ivx)+1
- if (ngrace .eq. 1) then
- ngstrt(ngrace) = 1
- else
- ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
- end if
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
- nng(ngrace) = 1
- multg(ngrace) = 1
- upg(ngrace) = .true.
- slurg(ngrace) = .false.
- slashg(ngrace) = .false.
-18 call getchar(lineq,iccount,charq)
- if (index('WA',charq) .gt. 0) then
-c
-c Grace is on note that was already done, so shift flags forward one note.
-c This puts flag on actual note with grace; later for W will go ahead one more.
-c
- ipg(ngrace) = nnl(ivx)
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
- if (slurg(ngrace))
- * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
- if (charq .eq. 'A') then
-c
-c close After, clear way-after bit, to ensure priority of most recent A/W
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
- else
-c
-c Way after; later assign to following note, and position like normal grace.
-c
- ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
- end if
- else if (charq .eq. 'm') then
- call getchar(lineq,iccount,charq)
- multg(ngrace) = ichar(charq)-48
- else if (index('123456789',charq) .gt. 0) then
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- nng(ngrace) = nint(fnum)
- else if (charq .eq. 'l') then
- upg(ngrace) = .false.
- else if (charq .eq. 's') then
- slurg(ngrace) = .true.
- if (nnl(ivx) .gt. 0) then
-c
-c If A- or W-grace, set signal to start slur on main note.
-c
- if(btest(ipl(ivx,nnl(ivx)),31) .or.
- * btest(ipl(ivx,nnl(ivx)),29))
- * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
- end if
- else if (charq .eq. 'x') then
- slashg(ngrace) = .true.
- else if (charq .eq. 'u') then
- else if (charq .eq. 'X') then
-c
-c Space before main note of grace. Number will come next.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,graspace(ngrace))
- iccount = iccount-1
- end if
- if (index('abcdefg',charq) .eq. 0) go to 18
-c
-c At this point, charq is first note name in grace
-c
- do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
- naccg(ing) = 0
- ioct = 0
- if (ing .gt. ngstrt(ngrace)) then
-55 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') go to 55
- endif
- iclastlev = 0
-9 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- iclastlev = iclastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- iclastlev = iclastlev-7
- else if (index('fsn',durq) .gt. 0) then
- if (naccg(ing) .eq. 0) then
- naccg(ing) = index('fsn',durq)
- else
-c
-c Double accidental
-c
- naccg(ing) = ibset(naccg(ing),2)
- end if
- else
- ioct = ichar(durq)-48
- end if
- go to 9
- end if
- if (ioct .gt. 0) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- lastlev = ndlev(iv,kv)+iclastlev
- end if
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- nolevg(ing) = lastlev
-19 continue
-c
-c Grace could come before first note of block, so reset end level.
-c
- if (nnl(ivx).eq.0) then
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- ndlev(iv,kv) = lastlev
- end if
- return
- end
- subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
-cccccccccccccccccccccccc
-cc
-cc GetiTransInfo.for
-cc
-cccccccccccccccccccccccc
-c
-c Called from both g1etnote and getnote, after first 'i' in Ki[...]
-c On entry, iccount points to last char retrieved, which is 'i'
-c
-c From1: locgical, true if called from g1etnote
-c ibarcnt: tells whether to set EarlyTransOn to true.
-c EarlyTransOn set false in blkdata, true here, back to false in topfile.
-c
-c 110522/110529
-c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey]
-c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0
-c so can pass to topfile (via comInstTrans), which is called before getnote.
-c Otherwise, will store info from getnote. Initialize EarlyTransOn and
-c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote;
-c LaterInstTrans from getnote. Zero both out after use. nInstTrans really
-c only needed for instrument-signatures, not transpositions. iTransAmt is
-c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for
-c each staff.
-c
-c iTransAmt stored as fn of instrument #, not like iTransKey which is
-c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This
-c simplifies use of iTransAmt for all calls to ifnolev.
-c
- parameter (nm=24)
- logical From1
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans,store
- character*128 lineq
- character*1 durq
- durq = 'x' ! Can't initialize in declaration stmt, only works once.
- if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0
- store = (EarlyTransOn.and.ibarcnt.eq.0) .or.
- * (ibarcnt.gt.0.and..not.From1)
- LaterInstTrans = .not.From1 .and. ibarcnt.gt.0
- if (store) nInstTrans = 0
-1 continue
- if (durq .eq. ' ') return
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be an instrument number here!')
- call stop1()
- end if
- if (store) nInstTrans = nInstTrans+1
- call readnum(lineq,iccount,durq,fnum)
- instn = nint(fnum)
- if (instn.gt.noinst) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Instrument number out of range!')
- call stop1()
- end if
- if (store) iInstTrans(nInstTrans) = instn
-c
-c durq is +/- following inst # (for iTransAmt), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after instrument number must be "+,-"!')
- call stop1()
- end if
- itramt = 44-ichar(durq) ! +1/-1 for itramt
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a transposition amount here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransAmt(instn) = nint(fnum)*itramt
-c
-c durq is +/- following iTransAmt (for iTransKey), iccount is on it.
-c
- if (index('+-',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '1st character after transposition amount must be "+,-"!')
- call stop1()
- end if
- ikey = 44-ichar(durq) ! +1/-1
- call g1etchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be a key indicator here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- if (store) iTransKey(nInstTrans) = nint(fnum)*ikey
-c
-c durq is now 1st character after iTransKey, should be either 'i' or ' '
-c
- if (durq.ne.'i'.and.durq.ne.' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'There must be blank or "i" here!')
- call stop1()
- end if
- go to 1
- end
- subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,first)
-c
-c Use this from both pmxa and pmxb to input and check midi data. "first" tells
-c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause
-c things to be written immediately into the midi storage buffers.
-c
- parameter (nm=24,mv=24576)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
-c
-c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing
-c nmidsec section starts and stops based on PLAYING macros (not recording).
-c
- integer*2 mmidi,midinum(26)
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- character*1 durq
- character*2 instq
- character*128 lineq
- logical first
- common /comdiag/ n69(0:nm),n34(0:nm)
-c
-c Instrument codes
-c
- data midinum
- * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67,
-c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX
-c
- * 68,69,71,72,74,75, 8,55 /
-c bsXobXbaXclXflXreXctXvo
-c
-1 call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Tempo in beats ber minute
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the pause!')
- call stop1()
-c else if (mmacrec) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Cannot change MIDI tempo while recording a MidiMacro!')
-c call stop1()
- end if
- call readnum(lineq,iccount,durq,qpm)
- iccount = iccount-1
- if (.not.first) then
- call midievent('t',nint(qpm),0)
- gottempo = .true.
- end if
- go to 1
- else if (durq .eq. 'p') then
-c
-c Insert a pause. pausemid = pause in 1/4's
-c
- call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here for the pause!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,pausemid)
- iccount = iccount-1
- if (.not.first) then
-c
-c Compute a meter for the pause. This is only to keep MidiNotate on track.
-c Round pause to nearest 16th. Let denominator always be 16.
-c
- numb16 = nint(pausemid*4)
- call midievent('m',numb16,16)
-c
-c Put in pausemid beats of rest
-c
- do 3 icm = 0 , numchan-1
- call addmidi(icm,0,0,0,4.*numb16,.true.,.false.)
-3 continue
- miditime = miditime+nint(240*pausemid)
-c
-c Restore meter
-c
- call midievent('m',mtrdenl*lenbar/64,mtrdenl)
- end if
- go to 1
- else if (durq .eq. 'i') then
-c
-c Instrument numbers or letters. Expect nv of them.
-c
- do 2 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (ichar(durq) .gt. 96) then
-c
-c It's a lowercase letter. Get another, find corr. instrument #.
-c
- instq(1:1) = durq
- call getchar(lineq,iccount,durq)
- instq = instq(1:1)//durq
- iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'//
- * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3
- if (iname .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Unrecognized 2-letter midi instrument name!')
- call stop1()
- end if
- midinst(ivx) = midinum(iname)-1
- else
-c
-c Expect a number, followed by ":" if that is followed by another number.
-c I.e., if after call to readnum, durq is not ":", it must be either blank
-c or next instrument letter.
-c
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi instrument number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midinst(ivx) = nint(fnum)-1
- if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi instrument number must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
- end if
-2 continue
- go to 1
- else if (durq .eq. 'v') then
-c
-c Get volumes for each instrument. Expect nv of them.
-c Follow same pattern as for insttrument numbers above.
-c
- do 7 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a midi velocity number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midivel(ivx) = nint(fnum)-1
- if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi velocity must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-7 continue
- go to 1
- else if (durq .eq. 'b') then
-c
-c Get balance for each instrument. Expect nv of them.
-c Follow same pattern as for instrument numbers above.
-c
- do 8 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a balance number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- midibal(ivx) = nint(fnum)-1
- if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Midi balance must be in range 1-128!')
- call stop1()
- end if
- if (durq .ne. ':') iccount = iccount-1
-8 continue
- go to 1
- else if (durq .eq. 'T') then
-c
-c Get transposition for each instrument. Expect nv of them.
-c Follow similar pattern as above, but separator is +|-.
-c
- do 9 ivx = 1 , nv
- call getchar(lineq,iccount,durq)
- ipm = index('-+',durq)
- if (ipm .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected "+" or "-" for midi transposition here!')
- call stop1()
- end if
- ipm = 2*ipm-3
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected a number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- miditran(ivx) = ipm*nint(fnum)
-c if (mod(miditran(ivx),12).ne. 0) then
-c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
-c * 'Midi transposition limited to multiples of 12!')
-c call stop1()
-c end if
- iccount = iccount-1
-9 continue
- go to 1
- else if (durq .eq. 'g') then
- call getchar(lineq,iccount,durq)
- if (index('0123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected an integer here for the midi gap!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- mgap = nint(fnum)
- iccount = iccount-1
- go to 1
- else if (durq .eq. 'M') then
-c
-c MidiMacros
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'R') then
-c
-c Start recording
-c
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to record a MidiMacro while already recording!')
- call stop1()
- end if
- mmacrec = .true.
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (immac .gt. 20) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'MidiMacro ID cannot exceed 20!')
- call stop1()
- end if
-c
-c Save the start time
-c
- mmactime(immac) = miditime
- do 4 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
-c
-c Adjust if there's a rest at end of prior section. Insert dummy turnoff.
-c (This causes two turn-offs in a row, which testmidi sees as an error).
-c
-c Before: section1 ------rest------- section2(to be recorded)
-c After: section1 rest1 now rest2 section2(recorded)
-c
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacstrt(icm,immac) = imidi(icm)+1
-4 continue
- end if
- go to 1
- else if (index('123456789P',durq) .eq. 0) then
-c
-c End recording; close the open macro. Get immac from common.
-c
- if (.not.mmacrec) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'You tried to end a MidiMacro before starting one!')
- call stop1()
- end if
- mmacrec = .false.
- iccount = iccount-1
- if (.not.first) then
-c
-c Save the macro duration
-c
- mmactime(immac) = miditime-mmactime(immac)
- do 5 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track if needed.
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- lasttime = miditime
- end if
- end if
- mmacend(icm,immac) = imidi(icm)
-5 continue
- end if
- if (durq .ne. ' ')go to 1
- else if (durq .eq. 'P') then
-c
-c Play Back a Macro
-c
- call getchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Expected MidiMacro ID number here!')
- call stop1()
- end if
- if (mmacrec) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'You tried to play a MidiMacro before ending recording!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- if (.not.first) then
- immac = nint(fnum)
- if (mmactime(immac) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a MIDI macro before recording it!')
- call stop1()
- end if
- do 6 icm = 0 , numchan
- if (icm .lt. numchan) then
- if (restpend(icm)) then
- call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
- trest(icm) = 0.
- restpend(icm) = .false.
- end if
- else
- if (miditime .gt. lasttime) then
-c
-c Insert a dummy turnoff in conductor track
-c
- call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
- * .false.,.true.)
- end if
- end if
- msecend(icm,nmidsec) = imidi(icm)
- msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac)
- msecend(icm,nmidsec+1) = mmacend(icm,immac)
- msecstrt(icm,nmidsec+2) = imidi(icm)+1
-6 continue
- nmidsec = nmidsec+2
-c
-c Update running time
-c
- miditime = miditime+mmactime(immac)
- lasttime = miditime
- end if
- go to 1
- else
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MidiMacro sub-command!')
- call stop1()
- end if
- else if (durq .eq. 'd') then
- debugmidi = .true.
- go to 1
- else if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character in MIDI input data!')
- call stop1()
- end if
- if (.not.gottempo .and. .not.first) then
-c
-c If no tempo is set on first call on the pmxb pass, then set it
-c
- call midievent('t',96,0)
- gottempo = .true.
- end if
- return
- end
- subroutine getnote(loop)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*10 figq
- character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax
- logical beamon,firstgulp,figbass,figchk,isfig
- character*60 cheadq
- character*120 instrq,titleq,compoq
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp,
- * was2,nobar1,quoted,isbj2,stickyS,
- * OptLineBreakTies,HeaderSpecial
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /combc/ bcspec
- common /comas3/ ask(2500),iask,topmods
-c
-c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined
-c ivx is current ivmx, and is the index for all notes, acc's etc.
-c
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comtrans/ cheadq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- common /comclefq/ clefq(nm)
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- character*128 txtdynq
- logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur,
- * fontslur,WrotePsslurDefaults
- character*128 lineq,lnholdq
- character*80 headrq, lowerq
- character*79 inameq
- character*59 hdlndq
- character*20 voltxtq
- character*1 charq,dotq,durq,ulfbq,dumq
- logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved,
- * topmods,headlog,btest,sluron,cdot,equalize
- character*24 tempq
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1,
- * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3
- logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3
- common /combibarcnt/ ibarcnt
- cdot = .false.
-1 call getchar(lineq,iccount,charq)
- if (lastchar) return
- if (charq .eq. ' ') go to 1
- if (charq .eq. '%') then
-c
-c Check for a bar number format:
-c
- if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and.
- * index('bB1234567890',lineq(3:3)).gt.0) then
- if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128))
- end if
- iccount = 128
- go to 1
- end if
-c
-c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r'
-c
- if (rptprev) then
- rptnd1 = charq .eq. '/'
- rptprev = .false.
- end if
-c
-c Repeat at end of a piece
-c
- if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
- * charq.eq.'r') then
- if (cdot) go to 28
-c
-c This is a note/rest.
-c
- idotform = 0
- numnum = 0
-c
-c If start of line of music, set pitch from previous
-c
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv)
-c
-c notcrd is used to tell if orn. goes on main note or chord note
-c
-c notcrd = .true. !Move dow. Was not observed if dotted shortcut.
-c
-c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts.
-c
-28 continue
-c
-c Moved this from just above, 2 Feb 02
-c
- notcrd = .true.
- nnl(ivx) = nnl(ivx)+1
- if (ornrpt) then
-c
-c Replicate ornament bits, also bit 23 for beam handling if chord.
-c
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- if (stickyS) then
-c
-c Grab stemlength shortening parameters from prior note
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
- call setbits (mult(ivx,nnl(ivx)),3,28,
- * igetbits(mult(ivx,nnl(ivx)-1),3,28))
- end if
- if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then
-c
-c Doing auto forced beams, and period has been set, so check if this note
-c starts a period.
-c
-c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Start a forced beam here
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- end if
- end if
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
- dotq = 'x'
- if (charq.eq.'r')
- * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (btest(irest(ivx,nnl(ivx)),0)) then
-c
-c Rest stuff. First check if previous note was full-bar-pause
-c
- if (lineq(iccount+1:iccount+1) .eq.' '
- * .and. nnl(ivx).gt.1) then
- if (btest(islur(ivx,nnl(ivx)-1),19))
- * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- end if
-c
-c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2
-c for voice a or b. Set a-types at 0 as encountered and adjust later
-c after '//'. (Override heights will be set to 100+offset)
-c
- if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- end if
-2 call getchar(lineq,iccount,durq)
- ic = ichar(durq)
- if (ic.le.57 .and. ic.ge.48) then
-c
-c Digit
-c
- if (numnum .eq. 0) then
- nnodur = ic-48
- numnum = 1
- go to 2
- else if (numnum .eq. 1) then
- ioct = ic-48
- numnum = 2
- go to 2
- else
- print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx)
- call stop1()
- end if
- else if (durq .eq. 'd') then
- dotq = durq
- if (lineq(iccount+1:iccount+1) .eq. 'd') then
-c
-c Double dot.
-c
- iccount = iccount+1
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3)
- end if
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0)
- * go to 2
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
- call getchar(lineq,iccount,durq)
- ndotmv(ivx) = ndotmv(ivx)+1
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx)))
- if (durq .eq. '-')
- * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx))
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx)))
- if (dumq .eq. '-')
- * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx))
- else
- rtdot(ivx,ndotmv(ivx)) = 0.
- end if
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. 'p') then
-c
-c Full-bar rest as pause
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'b') then
-c
-c Blank rest
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- go to 2
- else if (index('fsn',durq) .gt. 0) then
-c
-c Accidental
-c
- if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c
-c No accidental has been set yet
-c
- nacc(ivx,nnl(ivx)) = index('fsn',durq)
- else
-c
-c Repeated accid, so must be double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- go to 2
- else if (durq .eq. 'i') then
-c
-c Set flag for MIDI-only accidental.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- go to 2
- else if (index('+-<>',durq) .gt. 0) then
- ipm = index('- +',durq)-2
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
-c
-c A note, not a rest.
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (moved) go to 2
-c
-c Octave jump with a note
-c
- if (numnum .lt. 2) then
- lastlev = lastlev+ipm*7
- else
- ioct = ioct+ipm*1
- end if
- go to 2
- else
-c
-c Override default height of a rest
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (lineq(iccount-1:iccount-1) .eq. '.') then
-c
-c Kluge in case there is a shortcut ".". It will have been sucked up by
-c readnum. (Same doesn't hold for ",")
-c
- iccount = iccount-2
- go to 2
- end if
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
-c
-c There may be more characters for this rest
-c
- iccount = iccount-1
- go to 2
- end if
- else if (durq .eq. 'x') then
-c
-c Xtuplet. Count number of doubled notes (for unequal xtups)
-c
- if (btest(nacc(ivx,nnl(ivx)),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
-c
-c Will set all durations to 0 except last one. Set flag on this note.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28)
-c
-c Next input will be digit
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- ntup = nint(fnum)
- if (index('DF',durq) .gt. 0) then
-c
-c Double xtup note to make an un= xtup. Here xtup number already set but may also
-c have this command before.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = 1
- call getchar(lineq,iccount,durq)
- else if (durq .eq. 'd') then
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- end if
-c
-c Only other possibilities here are ' ' or 'n'
-c
- if (durq .eq. 'n') then
-c
-c Alter xtup number
-c
- if (lineq(iccount+1:iccount+1) .eq. ' ') then
-c
-c If the only modifier is 'n', cancel the number
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31)
- else
- numshft = 0
-30 call getchar(lineq,iccount,durq)
- if (durq .eq. 'f') then
-c
-c Flip up-down-ness
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14)
- go to 30
- else if (index('+-',durq) .gt. 0) then
-c
-c Vertical or horiz shift
-c
- numshft = numshft+1
- iofforn = 1
- if (durq .eq. '-') iofforn = -1
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- if (numshft .eq. 1) then
-c
-c Vertical shift
-c
- iofforn = iofforn*nint(xofforn) + 16
-c
-c Turn on bit 1; set bits 2-6 to iofforn
-c
- irest(ivx,nnl(ivx)) =
- * ior(irest(ivx,nnl(ivx)),2+4*iofforn)
- else
-c
-c Horizontal shift
-c
- iofforn = iofforn*nint(xofforn*10)+16
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7)
- call setbits(irest(ivx,nnl(ivx)),5,9,iofforn)
- end if
- go to 30
- else if (durq .eq. 's') then
-c
-c Slope adjustment for bracket
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4)
- call getchar(lineq,iccount,durq)
- iofforn = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,xofforn)
- iccount = iccount-1
- iofforn = nint(iofforn*xofforn+16)
- call setbits(mult(ivx,nnl(ivx)),5,5,iofforn)
- else if (index('123456789',durq) .gt. 0) then
-c
-c Replacement printed number
-c
- call readnum(lineq,iccount,durq,xofforn)
- call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn))
- iccount = iccount-1
- go to 30
- end if
- end if
- end if
-c
-c Set note level of 1st note of xtup, provided not a rest
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- end if
- do 40 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on starting note of xtuplet
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-40 continue
- numnum = 0
- nodur(ivx,nnl(ivx)) = 0
- do 6 itup = 2 , ntup
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
- nnl(ivx) = nnl(ivx)+1
- if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
-7 call getchar(lineq,iccount,charq)
- if (charq .eq. ' ') then
- go to 7
- else if (charq .eq. '%') then
- iccount = 128
- go to 7
- else if (charq .eq. 'o') then
-c
-c Ornament in xtuplet. "o" symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx)-1)
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1),
- * iornq(ivx,0),ornrpt,noffseg,
- * nnl(ivx)-1,ivx,.false.,notcrd,nole)
- go to 7
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)-1
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detected preslur in xtuplet loop, non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t') islur(ivx,nnlivx) =
- * ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
- * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- go to 7
- else if (charq .eq. 'G') then
-c
-c Kluge to get grace in xtup at right location
-c
- nnl(ivx) = nnl(ivx)-1
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- nnl(ivx) = nnl(ivx)+1
- go to 7
- else if (charq .eq. sq) then
- call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
- go to 7
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c Figure. Must come AFTER the first note of xtup
-c
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx),
- * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf))
- go to 7
- else if (charq .eq. 'X') then
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx,
- * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur,
- * dotq,ndoub)
- go to 7
- else if (charq .eq. 'z') then
-c
-c Chord note in xtup. Goes with *prior* note.
-c
- notcrd = .false.
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)-1
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-34 call getchar(lineq,iccount,durq)
-c
-c When chord note is done, will get ' ', making ndx=0, so go past this block
-c
- ndx = index('fsn+-<>12345678reic',durq)
- if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (ndx .eq. 19) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)-1) =
- * ibset(iornq(ivx,nnl(ivx)-1),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,
- * igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,
- * igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)-1) =
- * ibset(irest(ivx,nnl(ivx)-1),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else
-c
-c must be a number, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 34
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 41 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on chord note in xtup
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Following lines copied from loop for non-xtup, chord note, preslur
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0)
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0)
- isdat2(nsdat-npreslur+1) =
- * ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-41 continue
- go to 7
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)-1),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)-1
- ArpShift(NumArpShift) = fnum
- end if
- go to 7
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1),
- * iornq(ivx,nnl(ivx)-1),lineq,iccount)
- go to 7
-c+++
- else if (charq .eq. ']') then
-c
-c Multiplicity up-down, must have '][ '
-c
- islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20)
- iccount = iccount+2
- go to 7
-cc+++
- end if
-c
-c End of loop for xtup options. If here, charq must be a (non-crd) note name.
-c or rest
-c
- if (charq .eq. 'r') then
-c
-c Rest in xtup
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
- if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'b') then
-c
-c Blank rest in middle of xtup
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
- else
-c
-c Override height of embedded xtup rest
-c
- ipm = index('- +',durq)-2
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
- iccount = iccount-1
- end if
- else if (ivx .le. nv) then
- nolev(ivx,nnl(ivx)) = 0
- else
- nolev(ivx,nnl(ivx)) = 2
- end if
- end if
- notcrd = .true.
-8 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
- if (index('+-<>',durq) .gt. 0) then
-c
-c Accidental horizontal shift
-c
- call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
- if (.not.moved) then
- if (durq.eq.'+') then
- lastlev = lastlev+7
- else if (durq.eq.'-') then
- lastlev = lastlev-7
- end if
- end if
- else if (index('fsn',durq) .gt. 0) then
- if (nacc(ivx,nnl(ivx)) .eq. 0) then
-c
-c No accid set yet
-c
- nacc(ivx,nnl(ivx)) = index('fsn',durq)
- else
-c
-c Symbol must be repeated, so it's a double
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
- end if
- else if (durq .eq. 'i') then
-c
-c Set flag for midi-only accidental
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17)
-
- else if (durq .eq. 'c') then
-c
-c Set flags for cautionary accidental
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (index('ul',durq) .gt. 0) then
-c
-c Force stem direction for non-beamed xtup note
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- else if (durq .eq. 'e') then
-c
-c Left-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
-c
-c Right-shift main xtup note
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (index('DF',durq) .gt. 0) then
-c
-c Double an xtup note to make an unequal xtup
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- ndoub = ndoub+1
- else if (durq .eq. 'd') then
-c
-c Dotted xtup note
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27)
- else
-c
-c Must be an octave number
-c
- lastlev = ifnolev(charq,ichar(durq)-48
- * ,iTransAmt(instno(iv)))
- end if
- go to 8
- end if
- if (itup .lt. ntup) then
-c
-c Last note is handled *after* flowing out of the xtup if block, but still
-c within block for a note-rest. Set note level now (rest already done).
-c Could have problem here if rests & doubled notes are combined in xtup,
-c since might exit the loop at the wrong place. Worry about it later.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- lastlev = lastlev-3+mod(ifnolev(charq,10,
- * iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- nodur(ivx,nnl(ivx)) = 0
- do 42 npreslur = npreslur , 1 , -1
-c
-c Set note level for preslur on internal xtup note
-c
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-42 continue
- end if
- if (itup .eq. ntup-ndoub) go to 12
-6 continue
-12 continue
- if (ornrpt) then
- iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
- * iand(iornq(ivx,nnl(ivx)-1),10026991))
- if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
-c
-c This is a trill (bit 7 or 15) so must dup the parameters
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = nnl(ivx)
- xnsktr(ntrill) = xnsktr(ntrill-1)
- end if
- end if
-c
-c End of if-block for xtuplet input
-c
- else if (durq .eq. 'm') then
-c
-c Multi-bar rest: next 1 or two digits are # of bars.
-c For some purposes, pretend its one bar only
-c
- nodur(ivx,nnl(ivx)) = lenbar
- ibarmbr = nbars+1
- mbrest = 0
- xb4mbr = 0.
-20 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48.and.ichar(durq).le.57) then
- mbrest = 10*mbrest+ichar(durq)-48
- go to 20
- end if
- else if (index('ul',durq) .gt. 0) then
-c
-c Set stem flipper
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
- if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
- * ibset(islur(ivx,nnl(ivx)),17)
- go to 2
- else if (durq .eq. 'a') then
-c
-c "Alone", i.e., prohibit beam
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18)
- go to 2
- else if (durq .eq. 'r') then
-c
-c Right offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- go to 2
- else if (durq .eq. 'e') then
-c
-c Left offset by one notehead
-c
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- go to 2
- else if (durq .eq. 'S') then
-c
-c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4
-c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to
-c interbeams = internotes*2/3.
-c
- mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27)
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
-c
-c End stickyS. Grab data now from prior note, since we have to shut off stickyS.
-c
- call setbits (mult(ivx,nnl(ivx)),3,28,
- * igetbits(mult(ivx,nnl(ivx)-1),3,28))
- stickyS = .false.
- go to 2
- end if
-c
-c If durq .ne. ':' then iccount is now on the start of the number
-c
- call readnum(lineq,iccount,durq,dum)
- call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2))
- if (durq .eq. ':') then
- stickyS = .true.
- else
- iccount = iccount-1
- end if
- go to 2
- else if (durq .eq. ',') then
-c
-c 2:1 pattern
-c
- idotform = 3
-c
-c Now flow to duration setting, as if durq=' '
-c
- else if (durq .eq. '.') then
-c
-c Dotted pattern. Close out note. Mult time by 3/4.
-c Set time for next note to 1/4. Start the note.
-c
- idotform = 1
- else if (durq .eq. 'o') then
-c
-c Suppress rest centering
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25)
- go to 2
- else if (durq .eq.'L') then
-c
-c With keyboard rest option, look left
-c
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30)
- go to 2
- else if (index('DF',durq) .gt. 0) then
-c
-c Double note for xtup. Must check here in case "D" came before "x" or on
-c last note of xtup. Need to flag it in pmxa since affects horiz. spacing.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18)
- if (durq .eq. 'F') nacc(ivx,nnl(ivx)) =
- * ibset(nacc(ivx,nnl(ivx)),19)
- go to 2
- else if (durq .eq. 'A') then
-c
-c Accidental option
-c
- call getchar(lineq,iccount,durq)
-c
- if (durq .eq. 'o') then
-c
-c Ordered accidentals in a chord. Mark the main note.
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28)
- else
-c
-c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29)
- iccount = iccount-1
- end if
- go to 2
- else if (durq .ne. ' ') then
- print*,'Illegal character in note: ',durq,', ivx,nn:',
- * ivx,nnl(ivx)
- call stop1()
- end if
-c
-c Done with note/rest options. Set level and duration.
-c
- if (.not.btest(irest(ivx,nnl(ivx)),0)) then
- if (numnum .eq. 2) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- nolev(ivx,nnl(ivx)) = lastlev
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- nolev(ivx,nnl(ivx)) = lastlev
- end if
- do 43 npreslur = npreslur , 1 , -1
-c
-c Set level for preslur on normal note, non-chord
-c
- call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
-43 continue
- end if
- if (idotform .gt. 0) then
- if (idotform .eq. 1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2
- else if (idotform .eq. 2) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
- else if (idotform .eq. 3) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- else if (idotform .eq. 4) then
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
- end if
- else if (btest(islur(ivx,nnl(ivx)),19)) then
-c
-c Set duration of full-bar rest as pause
-c
- nodur(ivx,nnl(ivx)) = lenbar
-c
-c Use a one-line function to set nnodur. It gives inverse of ifnodur.
-c
- nnodur = index('62514x0x37',
- * chax(48+int(log(.1+lenbar)/.69315)))-1
- else if (ibarmbr.ne.nbars+1) then
- nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
- if (btest(islur(ivx,nnl(ivx)),3))
- * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
- end if
- if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then
-c
-c Shift is on, and this is not first shifted note. Check for duration change
-c
- if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then
-c
-c Must stop and restart the offset.
-c
- irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1)
- end if
- end if
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- if (autofbon .and. tautofb.gt.tol .and. fbon) then
-c
-c Check to see if need to terminate auto forced beam
-c
- if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then
-c
-c Terminate autofb
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- end if
- end if
- if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then
-c
-c Finished a bar
-c
- nbars = nbars+1
- nib(ivx,nbars) = nnl(ivx)
- if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then
-c
-c Just finished the pickup bar for this voice.
-c
- lenbar = lenb1
- end if
- end if
- if (idotform .eq. 1) then
- call getchar(lineq,iccount,charq)
- idotform = 2
- numnum = 1
- go to 28
- else if (idotform .eq. 3) then
- call getchar(lineq,iccount,charq)
- idotform = 4
- numnum = 1
- go to 28
- end if
-c
-c End of sub block for note-rest
-c
- else if (charq .eq. 'z') then
-c
-c Chord note. Must have note name, may have octave#,+,-,s,f,n,d
-c Actually the 'd' is not used, since time value comes from
-c basic note. Unless dot is to be shifted!
-c Doesn't increase # of notes, so must handle separately
-c ncrd: index of crd
-c Set bit 10 of ipl on main note as flag
-c Bits in icrdat:
-c 0-7 ip within voice
-c 8-11 ivx
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Cautionary accidental
-c
-c Bits in icrdot:
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
- ncrd = ncrd+1
- ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10)
- numnum = 0
-c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
- icrdat(ncrd) = nnl(ivx)
- call setbits(icrdat(ncrd),4,8,mod(ivx,16))
- if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28)
- icrdot(ncrd) = 0
- icrdorn(ncrd) = 0
-c
-c Get note name
-c
- call getchar(lineq,iccount,charq)
-c
-c Get optional inputs
-c
-25 call getchar(lineq,iccount,durq)
-c ndx = index('fsn+-<>12345678rediA',durq)
- ndx = index('fsn+-<>12345678rediAc',durq)
- if (ndx .eq. 20) then
-c
-c Expect +|-|<|> , set tag, loop
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),29)
- go to 25
- else if (ndx .gt. 0) then
- if (ndx .le. 3) then
- if (.not.btest(icrdat(ncrd),19)) then
- icrdat(ncrd) = ibset(icrdat(ncrd),19)
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
- else
- icrdat(ncrd) = ibset(icrdat(ncrd),22)
- end if
- else if (ndx .eq. 21) then
-c
-c Set flags for cautionary accidental
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),31)
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31)
- else if (ndx .le. 7) then
-c
-c +/-/</> Check whether octave or accidental shift
-c
- nactmp = 0
- call chkpm4ac(lineq,iccount,nactmp,moved)
- if (moved) then
-c
-c Transfer accidental shift values
-c
- call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4))
- call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10))
- else
- if (durq .eq. '+') then
- lastlev = lastlev+7
- else if (durq .eq. '-') then
- lastlev = lastlev-7
- end if
- end if
- else if (durq .eq. 'e') then
- icrdat(ncrd) = ibset(icrdat(ncrd),23)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
- else if (durq .eq. 'r') then
- icrdat(ncrd) = ibset(icrdat(ncrd),24)
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
- else if (durq .eq. 'i') then
-c
-c Midi-only accidental on chord note
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),27)
- else if (durq .eq. 'd') then
-c
-c Must keep 'd' optional (backward compatibility), unless it is moved!
-c
- if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
-c
-c move a dot, unless next char is not part of a number
-c
- if (index('0123456789.',lineq(iccount+2:iccount+2))
- * .eq. 0) go to 25
- icrdat(ncrd) = ibset(icrdat(ncrd),26)
- call getchar(lineq,iccount,durq)
- iccount=iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '+') then
- icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64)
- else
- icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64)
- end if
- if (index('+-',dumq) .gt. 0) then
-c
-c Vertical shift specified also
-c
- iccount=iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '+') then
- ifnum = nint(fnum*10)+64
- else
- ifnum = -nint(fnum*10)+64
- end if
- else
- ifnum = 64
- end if
- icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7))
- iccount = iccount-1
- end if
- else
-c
-c must be a single digit, save it in ioct
-c
- numnum = 1
- ioct = ndx-7
- end if
- go to 25
- end if
- if (numnum .eq. 1) then
- lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv)))
- else
- lastlev = lastlev-3
- * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7)
- end if
- icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
- do 44 npreslur = npreslur , 1 , -1
- call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
-c
-c Set level for chord note.
-c Initially I assigned the slur(s) to next note, so fix.
-c
- islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0)
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0)
- isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0)
- call setbits(isdat1(nsdat-npreslur+1),8,3,
- * igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
-44 continue
- if (notcrd) then
-c
-c This is the first chord note in this chord.
-c
- minlev = min(nolev(ivx,nnl(ivx)),lastlev)
- maxlev = max(nolev(ivx,nnl(ivx)),lastlev)
- else
- minlev = min(minlev,lastlev)
- maxlev = max(maxlev,lastlev)
- end if
- notcrd = .false.
- else if (charq .eq. 'G') then
- call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev,
- * lastlev,iv,nv)
- continue
-c
-c Grace, comes *before* main note:
-c UNLESS there's an 'A' or 'W' after the 'G'
-c ngrace = # of grace note groups so far in block
-c ivg(ngrace), ipg(ngrace)
-c nng(ngrace) = # of notes in this group: default = 1
-c ngstrt(ngrace) = starting position in nolevg of levels for this grace
-c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)'
-c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
-c slurg(ngrace) = logical for slur; default F, input 's'
-c slashg(ngrace) = T if slash; default is F, input 'x'
-c These data MUST precede note name of first note
-c nolevg, naccg: lists of levels and accid's, indexed as described above.
-c
-c ngrace = ngrace+1
-c ivg(ngrace) = ivx
-c ipg(ngrace) = nnl(ivx)+1
-c if (ngrace .eq. 1) then
-c ngstrt(ngrace) = 1
-c else
-c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
-c end if
-c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
-c nng(ngrace) = 1
-c multg(ngrace) = 1
-c upg(ngrace) = .true.
-c slurg(ngrace) = .false.
-c slashg(ngrace) = .false.
-c18 call getchar(lineq,iccount,charq)
-c if (index('WA',charq) .gt. 0) then
-cc
-cc Grace is on note that was already done, so shift flags forward one note.
-cc This puts flag on actual note with grace; later for W will go ahead one more.
-cc
-c ipg(ngrace) = nnl(ivx)
-c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
-c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
-c if (slurg(ngrace))
-c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
-c if (charq .eq. 'A') then
-cc
-cc close After, clear way-after bit, to ensure priority of most recent A/W
-cc
-c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
-c else
-cc
-cc Way after; later assign to following note, and position like normal grace.
-cc
-c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
-c end if
-c else if (charq .eq. 'm') then
-c call getchar(lineq,iccount,charq)
-c multg(ngrace) = ichar(charq)-48
-c else if (index('123456789',charq) .gt. 0) then
-c call readnum(lineq,iccount,durq,fnum)
-c iccount = iccount-1
-c nng(ngrace) = nint(fnum)
-c else if (charq .eq. 'l') then
-c upg(ngrace) = .false.
-c else if (charq .eq. 's') then
-c slurg(ngrace) = .true.
-c if (nnl(ivx) .gt. 0) then
-cc
-cc If A- or W-grace, set signal to start slur on main note.
-cc
-c if(btest(ipl(ivx,nnl(ivx)),31) .or.
-c * btest(ipl(ivx,nnl(ivx)),29))
-c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
-c end if
-c else if (charq .eq. 'x') then
-c slashg(ngrace) = .true.
-c else if (charq .eq. 'u') then
-c else if (charq .eq. 'X') then
-cc
-cc Space before main note of grace. Number will come next.
-cc
-c iccount = iccount+1
-c call readnum(lineq,iccount,durq,graspace(ngrace))
-c iccount = iccount-1
-c end if
-c if (index('abcdefg',charq) .eq. 0) go to 18
-cc
-cc At this point, charq is first note name in grace
-cc
-c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
-c naccg(ing) = 0
-c ioct = 0
-c if (ing .gt. ngstrt(ngrace)) then
-c55 call getchar(lineq,iccount,charq)
-c if (charq .eq. ' ') go to 55
-c endif
-c iclastlev = 0
-c9 call getchar(lineq,iccount,durq)
-c if (durq .ne. ' ') then
-c if (durq.eq.'+') then
-c lastlev = lastlev+7
-c iclastlev = iclastlev+7
-c else if (durq.eq.'-') then
-c lastlev = lastlev-7
-c iclastlev = iclastlev-7
-c else if (index('fsn',durq) .gt. 0) then
-c if (naccg(ing) .eq. 0) then
-c naccg(ing) = index('fsn',durq)
-c else
-cc
-cc Double accidental
-cc
-c naccg(ing) = ibset(naccg(ing),2)
-c end if
-c else
-c ioct = ichar(durq)-48
-c end if
-c go to 9
-c end if
-c if (ioct .gt. 0) then
-c lastlev = ifnolev(charq,ioct)
-c else
-c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
-c if (ivx .le. nv) then
-c kv = 1
-c else
-c kv = 2
-c end if
-c lastlev = ndlev(iv,kv)+iclastlev
-c end if
-c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
-c end if
-c nolevg(ing) = lastlev
-c19 continue
-cc
-cc Grace could come before first note of block, so reset end level.
-cc
-c if (nnl(ivx).eq.0) then
-c if (ivx .le. nv) then
-c kv = 1
-c else
-c kv = 2
-c end if
-c ndlev(iv,kv) = lastlev
-c end if
- else if (charq .eq. sq) then
-c
-c Literal TeX string
-c
- call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
- else if (charq .eq. 'o') then
-c
-c Ornament on non-xtup note. Symbol must come AFTER the affected note
-c
- if (notcrd) then
- nole = nolev(ivx,nnl(ivx))
- else
- nole = iand(127,ishft(icrdat(ncrd),-12))
- end if
- call getorn(lineq,iccount,iornq(ivx,nnl(ivx)),
- * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx,
- * .true.,notcrd,nole)
- else if (index('st(){}',charq) .gt. 0) then
- nnlivx = nnl(ivx)
- if (charq.eq.'(' .or. charq.eq.'{') then
-c
-c Detect preslur on normal non-chord note
-c
- nnlivx = nnlivx+1
- npreslur = npreslur+1
- end if
- islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
- if (charq.eq.'t')
- * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1)
- if (ivx .le. nv) then
- kv = 1
- else
- kv = 2
- end if
- if (fontslur) then
- call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev(ivx,nnlivx),charq)
- else
- call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq)
- end if
- else if (charq .eq. '?') then
-c
-c Arpeggio
-c
- if (btest(ipl(ivx,nnl(ivx)),10)) then
-c
-c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note
-c of chord, will not set icrdat(25), but iornq(27)
-c
- icrdat(ncrd) = ibset(icrdat(ncrd),25)
- else
- iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27)
- end if
-c
-c Check for shift
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- iccount = iccount-1
- else
-c
-c durq must be "-"
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
-c
-c record the shift
-c
- NumArpShift = NumArpShift+1
- IvArpShift(NumArpShift) = ivx
- IpArpShift(NumArpShift) = nnl(ivx)
- ArpShift(NumArpShift) = fnum
- end if
- else if (index('0123456789#-nx_',charq) .gt. 0) then
-c
-c We have a figure. Must come AFTER the note it goes under
-c
-
- ivf = 1
- if (ivx .gt. 1) then
- if (ivxfig2 .eq. 0) then
- ivxfig2 = ivx
- else if (ivx .ne. ivxfig2) then
- print*
- print*,'Figures not allowed in >1 voice above first'
- stop
- end if
- ivf = 2
- end if
- nfig1 = nfigs(ivf)+1
- call getfig(itoff(ivf,nfig1),charq,lineq,iccount,
- * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx),
- * nodur(ivx,nnl(ivx)),figq(ivf,nfig1),
- * ivupfig(ivf,nfig1),nfigs(ivf))
- else if (charq .eq. '[') then
-c
-c Start forced beam. Record barno & time since start of inp. blk. Set signal
-c
- nfb(ivx) = nfb(ivx)+1
- fbon = .true.
- ulfbq(ivx,nfb(ivx)) = 'x'
- t1fb(ivx,nfb(ivx)) = itsofar(ivx)
- nadj = 0
- if (autofbon) then
- autofbon = .false.
- end if
-17 call getchar(lineq,iccount,charq)
- if (index('ulf',charq) .gt. 0) then
- ulfbq(ivx,nfb(ivx)) = charq
- go to 17
- else if (charq .eq. 'j') then
-c
-c Continuing a jumped beam here
-c
- irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24)
-c
-c Set flag to watch for END of this forced beam, so can set flag rest(30) on
-c NEXT note as signal to start a new notes group there.
-c
- isbj2 = .true.
- go to 17
- else if (charq .eq. 'h') then
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2)
- go to 17
- else if (charq .eq. 'm') then
-c
-c Force multiplicity. Next input is digit
-c
- call getchar(lineq,iccount,charq)
- islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21)
- call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48)
- go to 17
- else if (charq .eq. ':') then
-c
-c Start auto forced beam pattern
-c
- autofbon = .true.
-c
-c When forced later beam ends, check whether tautofv <=0; if so set it.
-c
- tautofb = -itsofar(ivx)
- t1autofb = itsofar(ivx)
- go to 17
- else if (charq .ne. ' ') then
-c
-c Must be '+/-' for height or slope shift
-c
- nadj = nadj+1
-c
-c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level.
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- iadj = nint(fnum)
- if (charq .eq. '-') iadj = -iadj
- if (nadj .eq. 1) then
-c
-c This is a level shift. Note if 0 was entered, iadj = 30
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30)
- else if (nadj .eq. 2) then
-c
-c Must be a slope shift
-c
- call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30)
- else
-c
-c Beam-thk fine tune
-c
- call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj)
- end if
- go to 17
- end if
- else if (charq .eq. ']') then
- if (autofbon .and. tautofb.lt.tol) then
- tautofb=itsofar(ivx)+tautofb
- end if
- call getchar(lineq,iccount,charq)
- if (index('j ',charq) .gt. 0) then
-c
-c Since ']' comes AFTER note, itsofar has been updated. Set ending signal.
-c
- t2fb(ivx,nfb(ivx)) = itsofar(ivx)
- fbon = .false.
- if (charq .eq. 'j')
- * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23)
- if (isbj2) then
-c
-c This is the end of a fb segment of a jump beam. Set flag on NEXT note to
-c force start of new notes group, provided this is not last note in bar.
-c
- if (mod(itsofar(ivx),lenbar) .ne. 0)
- * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30)
- isbj2 = .false.
- end if
- else if (charq .eq. '[') then
-c
-c Multiplicity down-up signal
-c
- islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20)
- else if (charq .eq. '-') then
-c
-c Set signals for gap in single-slope beam [...]-[...]
-c
- nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20)
- nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21)
-c
-c Next two characters must be "[ ". Skip over them.
-c
- iccount = iccount+2
- end if
- else if (charq .eq. 'D') then
- call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)),
- * iornq(ivx,nnl(ivx)),lineq,iccount)
- else if (charq .eq. 'h') then
-c
-c Heading or height. For heading, only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "h" not at beginning of block'
- call stop1()
- end if
- call getchar(lineq,iccount,durq)
- ihdvrt = 0
- if (index('+-',durq) .gt. 0) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- ihdvrt = fnum+.1
- if (durq .eq. '-') ihdvrt = -ihdvrt
- durq = charq
- end if
- if (durq .ne. ' ') then
-c
-c Height symbol. Read past (until next blank)
-c
-3 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 3
- else
-c
-c Set flag for header & read it in
-c
- ihdht = 16
- call getbuf(headrq)
- iccount = 128
- end if
- else if (charq .eq. 'L') then
-c
-c Linebreak, already handled in pmxa, but check for movement break
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fmovbrk)
- if (durq .eq. 'P') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- end if
- if (durq .eq. 'M') then
- movbrk = nint(fmovbrk)
- movgap = 0
- parmov = -1.
- call getchar(lineq,iccount,durq)
-31 if (durq .eq. '+') then
-c
-c Get vertical space (\internotes)
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- movgap = nint(fnum)
- go to 31
- else if (durq .eq. 'i') then
- iccount = iccount+1
- call readnum(lineq,iccount,durq,parmov)
- go to 31
- else if (durq .eq. 'c') then
- nobar1 = .true.
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'r') then
-c
-c "rename" can be set on or off.
-c
- call getchar(lineq,iccount,durq)
- rename = durq.eq.'+'
- call getchar(lineq,iccount,durq)
- go to 31
- else if (durq .eq. 'n') then
-c
-c Change # of voices. Input ninow, iiorig(1...ninow). Will use names,
-c staves per inst. and clefs corr. to iiorig in original list of instruments.
-c
- nvold = nv
- nv = 0
- rename = .true.
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')ninow
- else
- ninow = ichar(durq)-48
- end if
- iiv = 0
- do 63 iinow = 1 , ninow
- call getchar(lineq,iccount,durq)
- if (durq .eq. ':') then
- iccount = iccount+2
- read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow)
- else
- iiorig(iinow) = ichar(durq)-48
- end if
- nspern(iinow) = nsperi(iiorig(iinow))
- nv = nv+nspern(iinow)
- sepsymq(iiv+nspern(iinow)) = '&'
- if (nspern(iinow) .gt. 1) then
- do 64 iis = 1 , nspern(iinow)-1
- sepsymq(iiv+iis) = '|'
-64 continue
- end if
- iiv = iiv+nspern(iinow)
-63 continue
- if (islast) then
- if (ninow .lt. 10) then
- write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%'
- else
- write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%'
- end if
- end if
- if (nv.eq.1 .and. nvold.gt.1) then
- if (islast) write(11,'(a)')sq//'nostartrule'
- else if (nv.gt.1 .and. nvold.eq.1) then
- if (islast) write(11,'(a)')sq//'startrule'
- end if
- iiv = 0
- do 60 iinow = 1 , ninow
- do 61 iis = 1 , nspern(iinow)
- iiv = iiv+1
-c
-c May not really need to re-enter clefs, but it's easier to program since
-c clef names are not saved but are needed in newvoice to set ncmidcc.
-c
- call getchar(lineq,iccount,clefq(iiv))
- call newvoice(iiv,clefq(iiv),.true.)
- if (nspern(iinow) .eq. 1) then
- hdlndq = chax(48+numclef(clefq(iiv)))
- lclf = 1
- else if (iis .eq. 1) then
- hdlndq = '{'//chax(48+numclef(clefq(iiv)))
- lclf = 2
- else if (iis .lt. nspern(iinow)) then
- hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))
- lclf = lclf+1
- else
- hdlndq =
- * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}'
- lclf = lclf+2
- end if
-61 continue
-c
-c setstaffs & setclef go by instrument, not voice
-c
- if (islast) then
- if (iinow .lt. 10) then
- write(11,'(a)')sq//'setstaffs'
- * //chax(48+iinow)//chax(48+nspern(iinow))//'%'
- write(11,'(a)')sq//'setclef'//chax(48+iinow)
- * //hdlndq(1:lclf)//'%'
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinow,
- * '}'//chax(48+nspern(iinow))//'%'
- write(11,'(a9,i2,a)')sq//'setclef{',iinow,
- * '}'//hdlndq(1:lclf)//'%'
- end if
- end if
-60 continue
-c
-c Loop back up, this may not be last option in M. Note flow out if durq=' '
-c
- call getchar(lineq,iccount,durq)
- go to 31
- end if
-c
-c Write instrument names
-c
- if (.not.rename) then
- do 62 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%'
- else
- write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%'
- end if
- end if
-62 continue
- else
- do 65 iinst = 1 , ninow
- if (islast) then
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,'{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'//
- * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
- end if
- end if
-65 continue
- rename = .false.
- end if
- end if
- else if (charq .eq.'|' ) then
-c
-c End of bar symbol. Check about end of bar hardspace.
-c
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by a bar line. Remove it from the hardspace
-c list, store with shifts instead, set special bit. Need to repeat this code
-c at '/'.
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- else if (index('wS',charq) .gt. 0) then
-c
-c Width symbol or new nsyst. Read past (until blank)
-c
-4 call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') go to 4
- else if (charq .eq. 'l') then
-c
-c Lower string. Only OK if at start of block
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "l" not at beginning of block'
- call stop1()
- end if
-c
-c Set flag for lower string & read it in
-c
- lower = .true.
- call getbuf(lowerq)
- iccount = 128
- else if (charq .eq. 'm') then
-c
-c Meter change. Only allow at beginning of block.
-c mtrnuml, mtrdenl (logical) and p (printable) will be input.
-c mtrnuml=0 initially. (In common)
-c
-c Check whether at beginning of a block
-c
- if (iv.ne.1 .or. nnl(1).ne.0) then
- print*,'You entered "m" not at beginning of block'
- call stop1()
- end if
- call readmeter(lineq,iccount,mtrnuml,mtrdenl)
- call readmeter(lineq,iccount,mtrnmp,mtrdnp)
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenbar = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenbar = lenbar*2
- lenb1 = lenbar
- lenb0 = 0
- if (ismidi) call midievent('m',mtrnuml,mtrdenl)
- else if (charq .eq. 'C') then
-c
-c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music.
-c
- if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1
- tcc(iv,ncc(iv)) = itsofar(iv)
- isl = ibset(islur(iv,nnl(iv)+1),11)
- call getchar(lineq,iccount,durq)
-c
-c Store clef number, or 7 if clef number = 9 (French violin clef)
-c
- isl = ior(isl,ishft(min(numclef(durq),7),12))
- ncmidcc(iv,ncc(iv)) = ncmidf(durq)
-c
-c Set marker on note with lowest voice # starting at same time.
-c
- if (iv .eq. 1) then
- isl = ibset(isl,15)
- else
- do 13 iiv = 1 , iv
- nnliiv = nnl(iiv)
- if (iiv .eq. iv) nnliiv = nnliiv+1
- itother = 0
- do 14 iip = 1 , nnliiv
- if (itother .lt. itsofar(iv)) then
- itother = itother+nodur(iiv,iip)
- go to 14
- else if (itother .eq. itsofar(iv)) then
- islur(iiv,iip) = ibset(islur(iiv,iip),15)
- go to 15
- end if
-14 continue
-13 continue
-15 continue
- end if
-c
-c Need 'or' since may have set bit 15 in the above loop
-c
- islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1))
- else if (charq .eq. 'R') then
-c
-c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1)
-c
-10 call getchar(lineq,iccount,durq)
-c
-c Save designator in case it's a terminal Rr or Rd
-c
- if (durq .eq. 'l') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5)
- go to 10
- else if (index('rdDbz',durq) .gt. 0) then
- if (durq .eq. 'r') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
- else if (durq .eq. 'd') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8)
- else if (durq .eq. 'D') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26)
- else if (durq .eq. 'b') then
- islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25)
- else if (durq .eq. 'z') then
- iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29)
- end if
- rptprev = .true.
- rptfq1 = durq
- go to 10
- end if
- else if (charq .eq. 'V') then
-c
-c Ending
-c
- nnnl = nnl(1)+1
- lvoltxt = 0
-11 call getchar(lineq,iccount,durq)
- if (durq.eq.'b' .or. durq .eq.'x') then
-c
-c End Volta, set bit9, and bit10 on if 'b' (end w/ box)
-c
- islur(1,nnnl) = ibset(islur(1,nnnl),9)
- if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10)
- go to 11
- else if (durq .ne. ' ') then
-c
-c Start volta; Get text
-c
- if (lvoltxt .eq. 0) then
-c
-c First character for text
-c
- lvoltxt = 1
- islur(1,nnnl) = ibset(islur(1,nnnl),7)
- nvolt = nvolt+1
- voltxtq(nvolt) = durq
- else
- voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq
- lvoltxt = lvoltxt+1
- end if
- go to 11
- end if
- else if (charq .eq. 'B') then
- bcspec = .not.bcspec
- else if (charq .eq. 'P') then
-c
-c Page numbers. Print stuff right now.
-c
- npg1 = 0
-c
-c Will use ltopnam to signal whether there's a centered heading
-c
- ltopnam = 0
- ipg1r = 0
-16 call getchar(lineq,iccount,durq)
- if (ichar(durq).ge.48 .and. ichar(durq).le.57) then
- npg1 = npg1*10+ichar(durq)-48
- go to 16
- else if (durq .eq. 'l') then
- if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1
- go to 16
- else if (durq .eq. 'r') then
- if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1
- go to 16
- else if (durq .eq. 'c') then
-c
-c Top-centered name. Assume this is last option. Read the name.
-c May surround name in double quotes (to allow blanks).
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. ' ') then
- ltopnam = lenstr(cheadq,60)
- else
- namstrt = iccount
- if (durq .eq. '"') then
-c
-c Using quote delimiters.
-c
- quoted = .true.
- namstrt = namstrt+1
- else
- quoted = .false.
- end if
- do 35 iccount = namstrt+1, 128
- if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or.
- * (.not.quoted .and. lineq(iccount:iccount) .eq. ' '))
- * go to 36
-c
-c On exit, iccount is OK, and name is in (namstrt:iccount-1)
-c
-35 continue
- print*,'Awww, cmon, should not be here.'
- call stop1()
-36 continue
- ltopnam = iccount-namstrt
- cheadq = lineq(namstrt:iccount-1)
- end if
- end if
-c
-c Done getting data, now assemble the command
-c
- if (npg1.eq.0) npg1=1
-c
-c 2/23/03 Don't use \atnextline if on first page and only one system
-c
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{'
- lhead = 27
-c else
-c hdlndq = sq//'toppageno{'
-c lhead = 11
-c end if
- if (npg1 .lt. 10) then
-c
-c Note we are overwriting the last "{"
-c
- write(hdlndq(lhead:lhead),'(i1)')npg1
- else if (npg1 .lt. 100) then
- lhead = lhead+3
- write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}'
- else
- lhead = lhead+4
- write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}'
- end if
- hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{'
- lhead = lhead+2
-c if (ipage.gt.1 .or. nsystp(1).gt.1) then
- if (ltopnam .eq. 0) then
- if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%'
- else
- if (islast)
- * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%'
- end if
-c else
-c if (ltopnam .eq. 0) then
-c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%'
-c else
-c if (islast)
-c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%'
-c end if
-c end if
- else if (charq .eq. 'W') then
-c
-c Just eat the number that must follow, it was used in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- else if (charq .eq. 'T') then
- headlog = .true.
- inhead = 0
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'i') then
- call getbuf(instrq)
-c
-c A kluge for parts from separate score file for later movements.
-c
- if (instrq(1:1) .eq. ' ') headlog = .false.
- cheadq = instrq
- else if (durq .eq. 't') then
- call getchar(lineq,iccount,durq)
-c
-c Optionally can include extra vertical \internotes above inbothd
-c
- if (index('-+0123456789',durq) .gt. 0) then
- ipm = 1
- if (index('+-',durq) .gt. 0) then
-c
-c Don't trust readnum to round this negative integer properly
-c
- iccount = iccount+1
- if (durq .eq. '-') ipm = -1
- end if
- call readnum(lineq,iccount,durq,fnum)
- inhead = ipm*nint(fnum)
- end if
- call getbuf(titleq)
- else
- call getbuf(compoq)
- end if
- inhead = inhead+inbothd
- iccount = 128
- else if (charq .eq. 'A') then
-c
-c Accidental handling etc.
-c
-27 call getchar(lineq,iccount,durq)
- if (durq .eq. 'r') then
- if (islast) then
- relacc = .true.
- write(11,'(a)')sq//'relativeaccid%'
- end if
- else if (durq .eq. 's') then
- bacfac = 1.e6
- else if (durq .eq. 'b') then
- if (islast) write(11,'(a)')sq//'bigaccid%'
- accfac = bacfac
- else if (durq .eq. 'a') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- iccount = iccount-1
- else if (durq .eq. 'i') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,tintstf)
- if (.not.firstgulp) fintstf = tintstf
-c
-c Local corrections for first page were handled by pmxa
-c
- iccount = iccount-1
- else if (durq .eq. 'I') then
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,gintstf)
- iccount = iccount-1
- else if (durq .eq. 'd') then
- lowdot = .true.
- else if (durq .eq. 'o') then
- continue
- else if (durq .eq. 'S') then
- do 50 iiv = 1 , nv
- call getchar(lineq,iccount,durq)
- if (index('-s',durq) .gt. 0) then
- fullsize(iiv) = 0.8
- else if (durq .eq. 't') then
- fullsize(iiv) = 0.64
- else
- fullsize(ivx) = 1.0
- end if
-50 continue
- else if (durq .eq. 'e') then
-c
-c Line-spacing equalization
-c
- equalize = .true.
-c
-c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so.
-c But it causes problems with some older scores and when excerpts are combined
-c with LaTeX. So as of 2.352 we write it here.
-c
- write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq
- * //'Interligne minus 99'//sq//'Interligne%'
- tempq = sepsymq(1)
- lentemp = 1
- do 51 iiv = 2 , nv-1
- tempq = tempq(1:lentemp)//sepsymq(iiv)
- lentemp = lentemp+1
-51 continue
- write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes'
- * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}'
- * //sq//'en}%'
- else if (durq .eq. 'v') then
-c
-c Toggle usevshrink
-c
- usevshrink = .not.usevshrink
- else if (durq .eq.'p') then
-c
-c Postscript slurs. fontslur is already false (set in g1etnote)
-c
- if (.not.WrotePsslurDefaults) then
-c
-c Set postscrirpt slur adjustment defaults
-c
- write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust'
- * //sq//'nohalfties'
- WrotePsslurDefaults = .true.
- end if
-52 continue
- call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l"
- if (index('+-',durq) .gt. 0) then
-c
-c Characters to change defaults for ps slurs
-c
- call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c"
- if (durq .eq. '+') then
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Sluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Tieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'halfties'
- else
- SlurCurve = SlurCurve + 1
- if (SlurCurve .gt. 3.1) then
- call printl('WARNING!')
- call printl
- * ('Default slur curvature advanced past HH, resetting')
- SlurCurve = 3
- end if
- end if
- else
- if (charq .eq. 's') then
- write(11,'(a)')sq//'Nosluradjust'
- else if (charq .eq. 't') then
- write(11,'(a)')sq//'Notieadjust'
- else if (charq .eq. 'h') then
- write(11,'(a)')sq//'nohalfties'
- else
- SlurCurve = SlurCurve - 1
- if (SlurCurve .lt. -1.1) then
- call printl('WARNING!')
- call printl(
- * 'Default slur curvature decremented below f, resetting')
- SlurCurve = -1
- end if
- end if
- end if
- go to 52 ! Check for another set of default changes
- else if (durq .eq. 'l') then
-c
-c Set optional linebreak ties
-c
- OptLineBreakTies = .true.
- go to 52
- else if (durq .eq. 'h') then
-c
-c Set flag to write header special on every page
-c
- HeaderSpecial = .true.
- go to 52
- else
- iccount = iccount-1
- end if
- else if (durq .eq. 'K') then
-c
-c Toggle keyboard rest placement flag
-c
- kbdrests = .not.kbdrests
- end if
-c if (durq .eq. 'N') then
- if (index('NR',durq) .gt. 0) then
-c
-c Override default part names for scor2prt, or normal include file.
-c Just bypass rest of input line
-c
- iccount = 128
- else if (durq .ne. ' ') then
- go to 27
- end if
- else if (charq .eq. 'K') then
- call getchar(lineq,iccount,durq)
- if (durq .ne. 'i') then
-c
-c Normal, full-score key change and/or transposition
-c
- num1 = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- num1 = num1*nint(fnum)
-c
-c On exit, durq='+','-'. But only need isig if after start, else done in pmxa
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (num1 .eq. 0) then
-c
-c Key change, not transposition.
-c
- ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28)
- lastisig = isig
- isig = nint(fnum)
- if (durq .eq. '-') isig = -isig
- isig = isig+idsig
- if (ismidi) call midievent('k',isig,0)
- else
-c
-c num1 .ne. 0, so transposition, so must be at beginning. isig came with K...
-c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data
-c (signature before transposition). idsig must be added to future key changes.
-c
- jv = 0
- do while (jv .lt. nm)
- jv = jv+1
- iTransAmt(jv) = num1
- end do
- idsig = isig-isig0
- end if
- else
-c
-c Instrument specific transposition.
-
- call GetiTransInfo(.false.,ibarcnt,lineq,iccount,
- * ibaroff,nbars,noinst,iv)
- end if
- else if (charq .eq. '/') then
- if (btest(iornq(ivx,nnl(ivx)+1),26)) then
-c
-c There was a hardspace followed by end of block. Remove it from the hardspace
-c list, store with shifts instead, set special bit. This code also at '|'
-c
- irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = udsp(nudsp)
- nudsp = nudsp-1
- iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
- end if
- call getchar(lineq,iccount,durq)
-c
-c Save ending note level:
-c
- if (ivx .le. nv) then
-c
-c This is the first line of music on this staff. If previous block had only 1
-c voice, save last pitch from line 1 of prev. block to line 2, in case a
-c 2nd line is started just below
-c
- if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1)
- was2(iv) = .false.
- ndlev(iv,1) = lastlev
- else
-c
-c This is the 2nd line of music on this staff.
-c
- was2(iv) = .true.
- ndlev(iv,2) = lastlev
- end if
- if (durq .eq. ' ' .and. iv.eq.nv) then
-c
-c End of input block
-c
- loop = .false.
- else
-c
-c Start a new line of music
-c
- if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0
- nbars = 0
- if (durq .eq. ' ') then
-c
-c New line of music is on next staff
-c
- iv = iv+1
- ivx = iv
- else
-c
-c durq must be 2nd '/'. New line of music is on same staff. Set up for it
-c
- ivx = nv+1
- do 23 iiv = 1 , nv
- if (nvmx(iiv) .eq. 2) ivx = ivx+1
-23 continue
- nvmx(iv) = 2
- ivmx(iv,2) = ivx
- itsofar(ivx) = 0
- nnl(ivx) = 0
- nfb(ivx) = 0
- nudoff(ivx) = 0
- ndotmv(ivx) = 0
- do 24 j = 1 , 200
- irest(ivx,j) = 0
- islur(ivx,j) = 0
- nacc(ivx,j) = 0
- iornq(ivx,j) = 0
- ipl(ivx,j) = 0
- mult(ivx,j) = 0
-24 continue
-c
-c Go back and lower the rests in voice "a" that don't have over-ridden heights
-c
- do 26 j = 1 , nnl(iv)
- if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0)
- * nolev(iv,j) = -4
-26 continue
- end if
- end if
- iccount = 128
- else if (charq .eq. 'X') then
-c
-c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index,
-c which only happens for normal X at block start, and we took special measures to
-c keep group shifts for crossing block boundaries.
-c
- call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))),
- * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx,
- * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub)
- else if (charq .eq. 'I') then
-c
-c Midi controls.
-c
- call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
- * mtrdenl,.false.)
- else if (charq .eq. 'M') then
-c
-c Macro action
-c
- call getchar(lineq,iccount,charq)
- if (index('RS',charq) .gt. 0) then
-c
-c Record or save a macro. Get the number of the macro.
-c
- call getchar(lineq,iccount,durq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call mrec1(lineq,iccount,ndxm)
- else
-c
-c Save (Record but don't activate)
-c
-5 call mrec1(lineq,iccount,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- iccount = 0
- go to 5
- end if
- iccount = iccount+ndxm+1
- end if
- else if (charq .eq. 'P') then
-c
-c Playback the macro
-c
- call getchar(lineq,iccount,charq)
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- ilmac = il1mac(macnum)
- mplay = .true.
- end if
- else if (index(',.',charq) .gt. 0) then
-c
-c Continued rhythmic shortcut
-c
- idotform = index('. ,',charq)
- if (idotform .eq. 1) then
-c
-c Check for start of forced beam on 2nd member of dotform=1 shortcut
-c
- if (fbon) then
- if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx))
- * t1fb(ivx,nfb(ivx)) =
- * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2
- end if
-c
-c Change duration of prior note
-c
- itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx))
- nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2
- itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
- end if
- idotform = idotform+1
- numnum = 1
- cdot = .true.
- go to 1
- end if
- return
- end
- subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg,
- * ip,ivx,noxtup,notcrd,nole)
-c
-c iornq: Main note. Do not alter if chord note, except turn on bit 23
-c iornq0: Store iorni + bit 23, in case of repeated ornaments
-c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd.
-c noffseg: horiz. offset for segno
-c nole: level of note w/ orn, used to ID the note/orn if there's a level shift.
-c
-
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comcb/ nbc,ibcdata(36)
- character*1 charq,durq
- character*128 lineq
- logical ornrpt,negseg,noxtup,notcrd
-c
-c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U
-c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD
-c
- call getchar(lineq,iccount,charq)
- if (index('bc',charq) .gt. 0) then
-c
-c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc)
-c ivx(0-3,28), ip(4-12),
-c vshift (vshift+32 in bits 13-18),
-c hshift (nint(10*vshift)+128 in bits 19-26)
-c bit 27 = 0 if caesura, 1 if breath
-c bit 28: 5th bit of ivx
-c
- iornq = ibset(iornq,28)
- nbc = nbc+1
-c ibcdata(nbc) = ivx+16*ip
- ibcdata(nbc) = mod(ivx,16)+16*ip
- if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28)
- if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27)
- call getchar(lineq,iccount,durq)
- if (index('+-',durq) .gt. 0) then
-c
-c We have a vertical shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,charq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),6,13,nint(32+fnum))
- if (index('+-',charq) .gt. 0) then
-c
-c Horizontal shift, get it
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum=-fnum
- call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128)
- end if
- end if
- return
- end if
-c
-c Set signal on main note that some note at this time has ornament. ONLY used
-c in beamstrt to activate further tests for whether ihornb is needed.
-c
- iornq = ibset(iornq,23)
-c
-c Isolate 21 bits defining exisiting ornaments
-c
- if (notcrd) then
- iorni = iand(4194303,iornq)
- else
- iorni = iand(4194303,icrdorn(ncrd))
- end if
- korn = index('stmgx+Tupf._)e:XXX>^',charq)
- if (korn .ne. 15) iorni = ibset(iorni,korn)
-c
-c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later
-c as follows: korn=16-18 for sfn, and or 21 for bare ?.
-c When this if-block is done, korn will = bit# of actual ornament (unless "?").
-c
- if (korn .eq. 15) then
-c
-cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq
-c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq
-c
-c iorni = ior(iorni,iand(iornq0,1638383))
- iorni = ior(iorni,iand(iornq0,3735535))
- ornrpt = .false.
- call getchar(lineq,iccount,durq)
-c
-c durq will be ' '
-c
- else if (korn .eq. 14) then
-c
-c Editorial accidental
-c
- call getchar(lineq,iccount,durq)
-c korn = 15+index('sfn',durq)
- korn = 15+index('sfn?',durq)
- if (korn .eq. 19) korn=21
- iorni = ibset(ibclr(iorni,14),korn)
- call getchar(lineq,iccount,durq)
- if (durq .eq. '?') then
-c
-c This is "oe[s|f|n]?". Set 21st bit also.
-c
- iorni = ibset(iorni,21)
- korn = korn+6
- call getchar(lineq,iccount,durq)
- end if
-c iorni = ibset(ibclr(iorni,14),korn)
- else if (korn.eq.4 .and. noxtup) then
-c
-c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points
-c
- noffseg = 0
- negseg = .false.
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Segno shift is specified
-c
- if (durq .eq. '-') then
- negseg = .true.
- call getchar(lineq,iccount,durq)
- end if
- call readnum(lineq,iccount,durq,fnum)
- noffseg = int(fnum)
- if (negseg) noffseg = -noffseg
- end if
- else if (korn .eq. 7) then
-c
-c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr"
-c
- ntrill = ntrill + 1
- ivtrill(ntrill) = ivx
- iptrill(ntrill) = ip
- xnsktr(ntrill) = 1.
- call getchar(lineq,iccount,durq)
- if (durq .eq. 't') then
-c
-c Convert to new internal symbol for non-'"tr" trill
-c
- korn = 15
- iorni = ibset(ibclr(iorni,7),15)
- call getchar(lineq,iccount,durq)
- end if
- if (index('0123456789.',durq) .gt. 0) then
-c
-c We have a number for the length
-c
- call readnum(lineq,iccount,durq,xnsktr(ntrill))
- end if
- else if (korn.eq.10 .and. noxtup) then
-c
-c Fermata
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'd') then
- korn = 14
- iorni = ibset(ibclr(iorni,10),14)
- call getchar(lineq,iccount,durq)
- end if
- else
- call getchar(lineq,iccount,durq)
- end if
- if (index('+- :',durq) .eq. 0) then
- print*,'Unexpected character at end of ornament: ',durq
- call stop1()
- end if
- if (index('+-',durq) .gt. 0) then
-c
-c Shift ornament up or down
-c
- nudorn = nudorn+1
-c
-c Set bit 25 in iorni as a signal. This may not really be necessary.
-c
- iorni = ibset(iorni,25)
-c
-c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev,
-c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present
-c
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- iofforn = nint(xofforn*fnum)
- kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12)
- * +ishft(korn,19)+ishft(iofforn+32,25)
- ivxudorn(nudorn) = ivx
- if (index('+-',durq) .gt. 0) then
-c
-c Horizontal shift
-c
- kudorn(nudorn) = ibset(kudorn(nudorn),31)
- xofforn = 44-ichar(durq)
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- ornhshft(nudorn) = nint(xofforn*fnum)
- end if
- else if (durq .eq. ':') then
-c
-c Turn on repeated ornaments
-c
- ornrpt = .true.
-c
-c Save the ornament value just set
-c
- iornq0 = iorni
- end if
- if (notcrd) then
- iornq = ior(iornq,iorni)
- else
- icrdorn(ncrd) = ior(icrdorn(ncrd),iorni)
- end if
- return
- end
- subroutine getpmxmod(global,includeq)
-c
-c If global=.true., checks for environment variable with path to pmx.mod.
-c Then, if variable exists and points to pmx.mod, insert lines from
-c pmx.mod into buffer
-c If global=.false., checks for existence of includeq and uses it.
-c
-c lenbuf0 = total length of bufq on entry
-c lbuf(i) = length of line (i)
-c nlbuf = number of lines stored in bufq
-c ilbuf = index of first line after setup stuff (on entry). In general, index of
-c next line to be sucked from buffer.
-c ilbufmod = counter for lines in pmx.mod as they are grabbed.
-c Starts at ilbuf. Points to position of next line after
-c pmx.mod stuff in bufq on exiting loop 1
-c ilbuff = transient counter for shifting operations
-c ipbuf = on entry, points to last character in setup stuff. In general, points
-c to last character of most recent line sucked from buffer.
-c ipbufmod = points to last character of most recent inserted line
-c from pmx.mod
-c
- parameter (maxblks=4000,nm=24)
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,fbon,issegno,isheadr,isvolt
- character*(*)includeq
- character*80 pmxmoddirq
- character*128 lnholdq
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- logical fexist,global
- line1pmxmod = ilbuf
- if (.not.global) then
- inquire(file=includeq,EXIST=fexist)
-c
-c Transfer includeq to temporary char variable with known length
-c
- pmxmoddirq = includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- print*
- write(15,'()')
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', checking further.')
-c
-c File named includeq doesn't not exist. Get directory from PMXMODDIR and
-c see if it's there
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq. gt. 0) then
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- else
- call printl(
- * 'No other directory defined by PMXMODDIR, stopping')
- call stop1()
- end if
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) then
- call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq)
- * //', stopping.')
- call stop1()
- end if
- end if
- call printl('Opening normal include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq)
- else
-c
-c Check for existence of pmx.mod
-c
- call getenv('PMXMODDIR',pmxmoddirq)
- lpmxmoddirq = lenstr(pmxmoddirq,80)
- if (lpmxmoddirq .eq. 0) return
- pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod'
- lpmxmoddirq = lpmxmoddirq+7
- inquire(file=pmxmoddirq,EXIST=fexist)
- if (.not.fexist) return
- call printl('Opening global include file '
- * //pmxmoddirq(1:lpmxmoddirq))
- open(18,file=pmxmoddirq(1:lpmxmoddirq))
- end if
- call printl('Adding include data')
-c
-c Read lines in from pmx.mod one at a time
-c
- ipbufmod = ipbuf
- lenbufmod = lenbuf0
- do 1 ilbufmod = ilbuf , maxblks
- read(18,'(a)',end=3)lnholdq
-c
-c A line was read. Slide all existing lengths from here forward ahead by 1
-c
- do 2 ilbuff = nlbuf , ilbufmod , -1
- lbuf(ilbuff+1) = lbuf(ilbuff)
-2 continue
-c
-c Get length of line from include file
-c
- lenmodline = lenstr(lnholdq,128)
- if (lenmodline .eq. 0) then
-c
-c Blank line. Make it a single blank with length 1
-c
- lenmodline = 1
- lnholdq = ' '
- end if
- lbuf(ilbufmod) = lenmodline
- call printl(lnholdq(1:lenmodline))
-c
-c Insert new stuff into bufq
-c
- bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)//
- * bufq(ipbufmod+1:lenbufmod)
-c
-c Update internal parameters
-c
- ipbufmod = ipbufmod+lbuf(ilbufmod)
- lenbufmod = lenbufmod+lbuf(ilbufmod)
- nlbuf = nlbuf+1
-1 continue
-3 continue
- call printl('Closing '//pmxmoddirq(1:lpmxmoddirq))
- close(18)
- linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf
- lenbuf0 = lenbufmod
-c
-c Fix Andre's error reporting problem 101211 leading to log(neg#) due
-c to nline being 2 bigger than it should be
-c
- nline=nline-2
-c
- return
- end
- subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0,
- * inameq,clefq,sepsymq,pathnameq,lpath,isig0)
- parameter (nm=24)
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*1 clefq(nm),sepsymq(nm)
- character*40 pathnameq
- character*79 inameq(nm)
- character*128 lineq
- logical istype0,newway,rename
-c
-c Get the first line
-c
- iccount = 0
-9 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 9
- istype0 = lineq(1:3).eq.'---'
- if (istype0) then
-c
-c Have TeX input until next line that starts with '---'. Save in scratch.
-c
- open(17,status='SCRATCH')
-3 call getbuf(lineq)
- if (lineq(1:3) .ne. '---') then
- write(17,'(a)')lineq
- go to 3
- end if
-c
-c Force a new line read on first call to readin
-c
- iccount = 128
- end if
-c
-c Here, lineq is first line w/ numerical setup data.
-c
- nv = nint(readin(lineq,iccount,nline))
- noinst = nint(readin(lineq,iccount,nline))
- newway = noinst.le.0
- if (newway) noinst = -noinst
- do 2 iinst = 1 , noinst
-c
-c Seve # of staves per inst in case later drop some inst's.
-c
- if (newway) then
-c
-c Read in nvi for each instrument
-c
- nsperi(iinst) = nint(readin(lineq,iccount,nline))
- else if (iinst .gt. 1 ) then
- nsperi(iinst) = 1
- else
- nsperi(iinst) = nv-noinst+1
- end if
- iiorig(iinst) = iinst
- nspern(iinst) = nsperi(iinst)
-2 continue
- mtrnuml = nint(readin(lineq,iccount,nline))
- mtrdenl = nint(readin(lineq,iccount,nline))
-cc
-cc Kluge to make mtrdenl work
-cc
-c if (mtrdenl .eq. 1) then
-c mtrdenl = 2
-c mtrnuml = mtrnuml*2
-c end if
- mtrnmp = nint(readin(lineq,iccount,nline))
- mtrdnp = nint(readin(lineq,iccount,nline))
- xmtrnum0 = readin(lineq,iccount,nline)
-c
-c Original key sig (before any trnasposition) in next position. Transposed
-c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key
-c changes if transposed.
-c
- isig0 = nint(readin(lineq,iccount,nline))
- npages = nint(readin(lineq,iccount,nline))
- nsyst = nint(readin(lineq,iccount,nline))
- musicsize = nint(readin(lineq,iccount,nline))
- fracindent = readin(lineq,iccount,nline)
-c
-c Next noinst non-comment lines are names of instruments.
-c
- do 4 i = 1 , noinst
-5 call getbuf(inameq(i))
- if (inameq(i)(1:1) .eq. '%') go to 5
-4 continue
-c
-c Mext non-comment line has nv clef names
-c
-6 call getbuf(lineq)
- if (lineq(1:1) .eq. '%') go to 6
- iv = 0
- nvsofar = 0
- do 1 jinst = 1 , noinst
- nvsofar = nvsofar+nsperi(jinst)
- do 10 ivi = 1 , nsperi(jinst)
- iv = iv+1
- clefq(iv) = lineq(iv:iv)
- if (iv .eq. nvsofar) then
- sepsymq(iv) = '&'
- else
- sepsymq(iv) = '|'
- end if
-10 continue
-1 continue
-c
-c Mext non-comment line has path name
-c
-8 call getbuf(pathnameq)
- if (pathnameq(1:1) .eq. '%') go to 8
- lpath = index(pathnameq,' ')-1
- return
- end
- function getsquez(n,ntot,space,tnote,to)
- real*4 tnote(600),to(600)
- common /comtol/ tol
-c
-c Get the squez factor by checking space against tgovern=minimum duration
-c of all notes sounding at time of n-th note in the list.
-c The starting time of base increment is to(n) and ending time is to(n)+space
-c Sounding notes are those that start at or before to(n) .and. end at or
-c after tend=to(n)+space
-c Since notes are ordered by increasing start times, as soon as we find one
-c that starts too late, we are done checking.
-c
- tgovern = 1000.
- tend = to(n)+space
- do 1 in = 1 , ntot
-c
-c Since to() is ordered by start times, exit loop after first note that
-c starts later than note of interest.
-c
-
- if (to(in) .gt. to(n)+tol) go to 2
- if (to(in)+tnote(in) .gt. tend-tol) then
-c
-c If here, this note overlaps and must be tested.
-c
- tgovern = min(tgovern,tnote(in))
- end if
-1 continue
-2 continue
- getsquez = space/tgovern
- return
- end
- subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx,
- * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub)
- parameter(nm=24)
-c
-c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol.
-c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
-c Since during getnote phase time is integer itsofar, which is not updated
-c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if
-c not in xtup.
-c
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical shifton,colon,ess,number
- character*128 lineq
- character*1 charq,durq,dotq
- colon = .false.
- ess = .false.
- number = .false.
- nextbl = iccount+index(lineq(iccount:128),' ')-1
- if (index(lineq(iccount:nextbl),'P') .gt. 0) then
-c
-c "Parts only", ignore entire symbol
-c
- iccount = nextbl
- return
- end if
-1 call getchar(lineq,iccount,charq)
- if (charq.eq.'B') then
-c
-c "Both parts and score," ignore character
-c
- go to 1
- else if (charq .eq. ':') then
- colon = .true.
- go to 1
- else if (charq .eq. 'S') then
- ess = .true.
- go to 1
- else if (index('+-.0123456789',charq) .gt. 0) then
- number = .true.
- if (charq.eq.'-') iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (charq .eq. '-') fnum = -fnum
- if (durq .ne. 'p') then
- fnum = fnum*wheadpt
- iccount = iccount-1
- end if
- go to 1
- end if
-c
-c charq must be blank, so done parsing
-c
- if (.not.ess .and. .not.colon) then
-c
-c Ordinary hardspace. Goes before next note.
-c (Later, at "|" or "/", check for presence and switch to udoff if there!)
-c
- nudsp = nudsp+1
- iornq1 = ibset(iornq1,26)
- udsp(nudsp) = fnum
- tudsp(nudsp) = itsofar
- if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp)
-c * +float(itup-1)/ntup*ifnodur(nnodur,dotq)
- * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq)
- else if (.not.number) then
-c
-c Must be "X:" End a group offset.
-c
- irest = ibset(irest,17)
- shifton = .false.
- return
- else
-c
-c Only other possibility is start offset, "S" for single, ':' for multiple
-c
- nudoff(ivx) = nudoff(ivx)+1
- udoff(ivx,nudoff(ivx)) = fnum
- if (ess) then
- irest1 = ibset(irest1,15)
- else
- irest1 = ibset(irest1,16)
- shifton = .true.
- end if
- end if
- return
- end
- function i1fnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- i1fnodur=1
- else if (idur .eq. 3) then
- i1fnodur=2
- else if (idur .eq. 1) then
- i1fnodur=4
- else if (idur .eq. 8) then
- i1fnodur=8
- else if (idur .eq. 4) then
- i1fnodur=16
- else if (idur .eq. 2) then
- i1fnodur=32
- else if (idur .eq. 0) then
- i1fnodur=64
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- i1fnodur=4
- else if (idur .eq. 9) then
- i1fnodur = 128
- else
- print*
- print*,'You entered an invalid note-length value:',idur
- call stop1()
- end if
- if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2
- return
- end
-c integer*4 function longi(ishort)
-c integer*2 ishort
-c longi = ishort
-c return
-c end
- function iashft(nacc)
- integer*4 ias(6)
- data ias /-1,1,0,0,-2,2/
- iashft = ias(nacc)
- return
- end
- function ifnodur(idur,dotq)
- character*1 dotq
- if (idur .eq. 6) then
- ifnodur=1
- else if (idur .eq. 3)then
- ifnodur=2
- else if(idur .eq. 1) then
- ifnodur=4
- else if(idur .eq. 8) then
- ifnodur=8
- else if(idur .eq. 4) then
- ifnodur=16
- else if(idur .eq. 2) then
- ifnodur=32
- else if(idur .eq. 0) then
- ifnodur=64
- else if(idur .eq. 9) then
- ifnodur=128
- else if (idur .eq. 16) then
-c
-c Only used for denominator of time signatures, not for notes
-c
- ifnodur=4
- else
- print*,'You entered an invalid note value'
- stop
- end if
- if (dotq .eq. 'd') ifnodur = ifnodur*3/2
- return
- end
- function ifnolev(noq,oct,ntrans)
- character*1 noq
- integer oct
- ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans
- return
- end
-c subroutine report(nsdat,isdat1,isdat2)
-c integer*4 isdat1(202),isdat2(202)
-c write(*,'(a)')
-c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd'
-c do 1 isdat = 1 , nsdat
-c isdata = isdat1(isdat)
-c ionoff = igetbits(isdata,1,11)
-cc iv = iand(7,isdata)
-c iv = igetbits(isdata,5,13)
-c kv = igetbits(isdata,1,12)+1
-c ip = igetbits(isdata,8,3)
-c idcode = igetbits(isdata,7,19)
-c iud1 = igetbits(isdata,1,26)
-c iud2 = igetbits(isdata,1,27)
-c ndxslur = igetbits(isdata,4,28)
-c isdatb = isdat2(isdat)
-c ivo = igetbits(isdatb,6,6)-32
-c iho = igetbits(isdatb,7,12)-64
-c lev = igetbits(isdatb,7,19)
-c icrd = igetbits(isdatb,1,0)
-c lhd = igetbits(isdatb,1,1)
-c irhd = igetbits(isdatb,7,2)
-c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur,
-c * ivo,iho,lev,icrd,lhd,irhd
-c1 continue
-c print*
-c return
-c end
- function igetbits(isdata,iwidbit,ishift)
-c
-c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and
-c then added to ioff
-c
- igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift))
- return
- end
- function igetvarlen(mmidi,icm,imidi,nbytes)
-c
-c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes.
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi(0:nm,mv)
- igetvarlen = 0
- do 1 nbytes = 1 , 4
- igetvarlen = 128*igetvarlen
- * +iand(127,mmidi(icm,imidi+nbytes))
-c * +iand(127,longi(mmidi(icm,imidi+nbytes)))
- if (.not.btest(mmidi(icm,imidi+nbytes),7)) return
-c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return
-1 continue
- print*,'Messup in igetvarlen'
- call stop1()
- end
- logical function isdotted(nodur,ivx,ip)
- parameter (nm=24)
-c
-c Function returns true if note is dotted or double-dotted.
-c Return false for any xtuplet.
-c
- common /comtol/ tol
- integer*4 nodur(nm,200)
- if (nodur(ivx,ip) .eq. 0) then
- isdotted = .false.
- return
- else if (ip .gt. 1) then
- if (nodur(ivx,ip-1) .eq. 0) then
- isdotted = .false.
- return
- end if
- end if
-c
-c Ruled out all xtups, so is dotted or double-dotted if not a power of 2.
-c
- isdotted =
- * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol
- return
- end
- function isetvarlen(idur,nbytes)
- isetvarlen = 0
- itemp = idur
- do 1 nbytes = 1 , 4
- isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1)
- itemp = ishft(itemp,-7)
- if (itemp .gt. 0) then
- isetvarlen = isetvarlen+2**(8*nbytes+7)
- else
- return
- end if
-1 continue
- print*,'Problem in function isetvarlen'
- call stop1()
- end
- subroutine istring(i,string,len)
-c
-c Returns string with integer only if length is 1, otherwise enclosed in
-c brackets.
-c
- character*(*) string
- if (i .ne. 0) then
- len = alog10(abs(i)*1.0001)+1
- if (i .lt. 0) len = len+1
- else
- string = '0'
- len = 1
- return
- end if
- if (len .eq. 1) then
- string = char(48+i)
- else
- string = '{'
- write(string(2:1+len),'(i'//char(48+len)//')')i
- string = string(1:len+1)//'}'
- len = len+2
- end if
- return
- end
- function lenstr(string,n)
- character*(*) string
- do 1 lenstr = n , 1 , -1
- if (string(lenstr:lenstr) .ne. ' ') return
-1 continue
- lenstr = 0
- return
- end
- function levrn(nolev,irest,iud,ncm,mult)
-c
-c Used for placing numbers in xtups. Returns note level if not a rest,
-c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm.
-c
- logical btest
- if (.not.btest(irest,0)) then
- levrn = nolev
- else
-c
-c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default.
-c
- if (mult .gt. 0) then
- if (mult .eq. 2) then
- ioff = -1+2*iud
- else if (mult .ne. 4) then
- ioff = iud*mult
- else
- ioff = 1+4*iud
- end if
- else
-c
-c May need to futz with this later for non-beamed xtups (quarter, half rests)
-c
- ioff = iud*2
- end if
- levrn = mod(nolev+20,100)-20+ncm+ioff
- endif
- return
- end
- function lfmt1(x)
-c
-c Computes total length of an "f" format with one decimal place.
-c First round to nearest 0.1
-c
- if (abs(x) .lt. .001) then
- lfmt1 = 2
- else
- y = sign(.1*int(10*abs(x)+.5),x)
- lfmt1 = int(log10(1000*abs(y)+.001))
- if (y .lt. 0) lfmt1 = lfmt1+1
- end if
- return
- end
- subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- parameter (nm=24)
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comoct/ noctup
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie
- character*1 udq,chax,sepsymq(nm)
- character*8 noteq
- character*128 notexq
-c
-c This is called twice from pmxb after having input an entire block, before
-c making a bar that starts a new system. So nsdat reflects all slur starts
-c and stops in new block, while listslur, which is only set when bars are
-c made, reflects only open slurs from the old block. So we must check
-c listslur to find open ties, not all nsdat.
-c First of two calls (ispstie=.false. on entry) terminates tie at end of line.
-c Second (ispstie=.true. on entry) restarts tie at start of new line. Only
-c need data from original tie-start for both of these. Tie/slur data from
-c closing of full tie are not used except for shape alterations.
-c
-c do 1 ndx = 0 , 11
- do 1 ndx = 0 , 23
- if (btest(listslur,ndx)) then
-c
-c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie
-c
- do 2 isdat = 1 , nsdat
-c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index
- if (igetbits(isdat1(isdat),4,28)
- * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index
- if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop
- if (btest(isdat2(isdat),3)) go to 3 ! "st"
- idcode = igetbits(isdat1(isdat),7,19)
- if (idcode.eq.1) go to 3 ! "t"
- tie = .false.
- go to 5
-2 continue
- end if
- go to 1
-3 continue
- tie = .true.
-5 continue
-c
-c A slur or tie is open, with index ndx
-c
- iv = igetbits(isdat1(isdat),5,13)
- kv = igetbits(isdat1(isdat),1,12)+1
- udq = 'd'
- if (btest(isdat1(isdat),27)) udq='u'
- notexq = chax(92)//'znotes'
- lnote = 7
- do 4 iiv = 1 , iv-1
- notexq = notexq(1:lnote)//sepsymq(iiv)
- lnote = lnote+1
-4 continue
- if (kv .eq. 2) then
- notexq = notexq(1:lnote)//chax(92)//'nextvoice'
- lnote = lnote+10
- end if
-c
-c Compute horiz and vert offsets
-c
-c nolev = igetbits(isdat2(isdat),7,19)
- islhgt = igetbits(isdat3(isdat),8,14)
- ilb12 = 0
- if (ispstie) ilb12 = 1
- ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32
- if (ivoff .eq. -32) ivoff = 0
-C nolev = nolev+ivoff
- islhgt = islhgt+ivoff
- ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff
- if (ihoff .eq. -64) ihoff = 0
-c
-c Add starting stuff for command
-c
- if (.not.ispstie) then ! End 1st segment
- notexq = notexq(1:lnote)//chax(92)//'roffset{'
- lnote = lnote+9
-c hoff = ihoff*.1-.5
-c hoff = ihoff*.1-.8
- hoff = ihoff*.1-.4
- if (hoff .lt. 0) then
- hoff = -hoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(hoff,notexq,lnote)
- notexq = notexq(1:lnote)//'}{'
- lnote = lnote+2
- else
- notexq = notexq(1:lnote)//chax(92)//'off{-'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+21
-c
-c 091025 add dotting for 2nd segment if needed
-c
- if (btest(isdat2(isdat),4)) then
- notexq = chax(92)//'dotted'//notexq(1:lnote)
- lnote = lnote+7
- end if
- end if
- if (ispstie .and. tie) then
- notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq
- lnote = lnote+10
- end if
- if (btest(isdat3(isdat),0)) then
-c
-c Curvature tweak on termination of 1st seg
-c
- imid = igetbits(isdat3(isdat),6,2)-32
-c
-c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping:
-c Abs(imid) Postscript slur type
-c 1 f
-c 4 h
-c 5 H
-c 6 HH
-c
- notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid)
- lnote = lnote+9
-c
-c Zero out the flag in case there's a different curv on term of 2nd,
-c
- isdat3(isdat) = ibclr(isdat3(isdat),0)
- end if
-c
-c Add the command name
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'is'//udq
- lnote = lnote+4
- else if (tie) then
- notexq = notexq(1:lnote)//chax(92)//'ttie'
- lnote = lnote+5
- else
- notexq = notexq(1:lnote)//chax(92)//'tslur'
- lnote = lnote+6
- end if
-c
-c Add index
-c
-c if (11-ndx .lt. 10) then
-c notexq = notexq(1:lnote)//chax(59-ndx)
-c lnote = lnote+1
-c else
-c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}'
-c lnote = lnote+4
-c end if
- if (23-ndx .lt. 10) then
- notexq = notexq(1:lnote)//chax(71-ndx)
- lnote = lnote+1
- else if (23-ndx .lt. 20) then
- notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}'
- lnote = lnote+4
- end if
- if (ispstie .or. .not.tie) then
-c
-c Add note name for slur height
-c
- noctup = 0
- ncm = igetbits(isdat3(isdat),8,22)
- if (ncm .eq. 23) noctup = -2
-c call notefq(noteq,lnoten,nolev,ncm)
- call notefq(noteq,lnoten,islhgt,ncm)
- notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}'
- lnote = lnote+1+lnoten+1
- end if
- if (ispstie) then
-c
-c Horizontal shift start of new thing
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
-c ihoff = ihoff-13
- if (tie) then
- ihoff = ihoff-12
- else
- ihoff = ihoff-7
- end if
- if (ihoff .lt. 0) then
- ihoff = -ihoff
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- call writflot(ihoff*.1,notexq,lnote)
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
-c
-c Add closing stuff
-c
- if (ispstie) then
- notexq = notexq(1:lnote)//chax(92)//'off{'
- * //chax(92)//'afterruleskip}'
- lnote = lnote+20
- else
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- notexq = notexq(1:lnote)//chax(92)//'en%'
- lnote = lnote+4
- write(11,'(a)')notexq(1:lnote)
-1 continue
- ispstie = .not.ispstie
- return
- end
- subroutine littex(islur,nnl,iv,topmods,lineq,iccount)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- integer islur(nm,200)
- logical topmods
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,merge
- character*128 lineq,litq
- character*20 voltxtq
- character*1 durq,chax
- merge = .false.
- if (nlit .gt. 0) then
- merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit)
- end if
- nlit = nlit+1
- ivlit(nlit) = iv
- iplit(nlit) = nnl
- itype = 1
-17 call getchar(lineq,iccount,durq)
- if (durq .eq. chax(92)) then
- itype=itype+1
- go to 17
- end if
- litq(nlit) = chax(92)//durq
- lenlit(nlit) = 2
-18 call getchar(lineq,iccount,durq)
- if (durq.eq.chax(92)) then
- call getchar(lineq,iccount,durq)
- if (durq .ne. ' ') then
-c
-c Starting a new tex command within the string
-c
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq
- lenlit(nlit) = lenlit(nlit)+2
- go to 18
- end if
- else
- litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq
- lenlit(nlit) = lenlit(nlit)+1
- go to 18
- end if
-c
-c If here, just read backslash-blank so string is done
-c
- if (itype .eq. 1) then
- islur(iv,nnl) = ibset(islur(iv,nnl),16)
- if (merge) then
-c
-c There are 2 separate strings on the same note, so merge them.
-c
- nlit = nlit-1
- litq(nlit) = litq(nlit)(1:lenlit(nlit))
- * //litq(nlit+1)(1:lenlit(nlit+1))
- lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1)
- if (lenlit(nlit) .gt. 128) then
- print*
- print*,
- * 'Merged type-1 TeX strings longer than 128 characters'
- write(15,'(/,a)')
- * 'Merged type-1 TeX strings longer than 128 characters'
- call stop1()
- end if
- end if
- else
- if (itype .eq. 3) then
-c
-c Write the string NOW
-c
- if (islast)
- * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- else
-c
-c Must go at top
-c
- if (.not.topmods) then
- topmods = .true.
- open(16,status='SCRATCH')
- end if
-c
-c Must write '%' here rather than later, in case string ends with blank.
-c
- write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
- end if
- nlit = nlit-1
- end if
- return
- end
- function llen(strq,n)
- character*129 strq
- do 1 llen = n , 0 , -1
- if (strq(llen:llen) .ne. ' ') return
-1 continue
- end
- function log2(n)
-c
-c 5/25/08 Modify to allow more slurs
-c
-c log2 = alog(1.*n)/0.6931472+.0001
-c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0
- log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0
- return
- end
- subroutine logbeam(numnew,nip1,nip2)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq,ulfq,ulfbq
- logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest,
- * autofbon
- ibm1(ivx,numnew) = nip1
- ibm2(ivx,numnew) = nip2
- numnow = numnew
- if (numnew .gt. 1) then
-c
-c If it starts before any others, must put it in order
-c
- do 11 ib = numnew-1 , 1 , -1
- if (ibm1(ivx,ib) .lt. nip1) go to 12
- ibm1(ivx,ib+1) = ibm1(ivx,ib)
- ibm2(ivx,ib+1) = ibm2(ivx,ib)
- ulq(ivx,ib+1) = ulq(ivx,ib)
- ibm1(ivx,ib) = nip1
- ibm2(ivx,ib) = nip2
- numnow = ib
-11 continue
-12 continue
- end if
- sum = 0.
-c
-c Beam has non-xtup within
-c
- nrests = 0
- isxtup = .false.
- do 9 iip = nip1 , nip2
- if (btest(islur(ivx,nip1),21)) then
-c
-c Forced multiplicity
-c
-c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22)
- call setbits(mult(ivx,iip),4,0,
- * igetbits(islur(ivx,nip1),3,22)+8)
- else if (.not.isxtup) then
- if (nodur(ivx,iip) .gt. 0) then
-c mult(ivx,iip) = 4-log2(nodur(ivx,iip))
- call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8)
- else
-c
-c Start xtup within forced beam
-c
- isxtup = .true.
- iip1 = iip
- end if
- else if (isxtup .and. nodur(ivx,iip).gt.0) then
-c
-c End of xtup within forced beam. Must count doubled notes
-c
- ndoub = 0
- do 1 iiip = iip1 , iip
- if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1
-1 continue
- multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)-
- * alog(nodur(ivx,iip)/2.))/0.69315)-10
- do 74 iiip = iip1 , iip
-c mult(ivx,iiip) = multx
- call setbits(mult(ivx,iiip),4,0,multx+8)
-c
-c Note the following still works after making mult only the 1st 4 bits.
-c
- if (btest(nacc(ivx,iiip),18))
- * mult(ivx,iiip) = mult(ivx,iiip)-1
- if (btest(nacc(ivx,iiip),19)) then
- mult(ivx,iiip) = mult(ivx,iiip)+1
- else if (iiip .gt. 1) then
- if (btest(nacc(ivx,iiip-1),19))
- * mult(ivx,iiip) = mult(ivx,iiip)+1
- end if
-74 continue
- isxtup = .false.
- end if
- if (btest(irest(ivx,iip),0)) then
- nrests = nrests+1
- else
- sum = sum+nolev(ivx,iip)
- end if
-9 continue
-c
-c Set beam up-down-ness
-c
- if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then
- if (ulfbq(ivx,ifb) .eq. 'f') then
-c
-c Get default, then trade "l" and "u"
-c
- ulq(ivx,numnow) = char(225-ichar(
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))))
- else
- ulq(ivx,ifb) = ulfbq(ivx,ifb)
- end if
-c
-c This probably works only because forced beams are done first, so they
-c don't have to be re-sorted within each voice. ????
-c
- else if (nvmx(iv) .eq. 2) then
-c
-c Multi-voice per staff
-c
- if (ivx .le. nv) then
- ulq(ivx,numnow) = 'l'
- else
- ulq(ivx,numnow) = 'u'
- end if
- else
-c
-c Defaults
-c
- ulq(ivx,numnow) =
- * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))
- end if
- return
- end
- subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=4000)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- logical mrecord,mplay,endmac
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- lbuf(1) = lbuf(1)
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then
- call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1,
- * 'Improper macro termination!')
- call stop1()
- end if
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- parameter (nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst
- common /comeskz2/ eskz2(nm,200)
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm),
- * numbms(nm),mapfb(16)
- real*4 xit(nm),t1xtup(20),tstart(80),squez(80)
- character*1 ulfbq
- character*79 inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 headrq,lowerq
- logical cwrferm
- common /comcwrf/ cwrferm(nm)
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical lower,cwrest(nm),vxtup,flgndb,btest,upslur,
- * infbmx(nm),lowdot,inxtup(nm),drawbm
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Above are factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /comtol/ tol
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur,
- * WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comntot/ ntot
- if (ismidi) then
-c
-c Initialize for this bar the accidental counter for the midi file.
-c naccim(icm) = # of accidentals from earlier in the bar
-c
- do 45 iv = 1 , nv
- do 45 kv = 1 , nvmx(iv)
- naccim(midchan(iv,kv)) = 0
-45 continue
- end if
-c
-c Time from start of gulp to end of bar, used with forced beams
-c
- tglp2 = lenb0+ibar*lenb1
- if (lenb0 .gt. 0) tglp2 = tglp2-lenb1
- tglp1 = tglp2-lenbar
-c
-c infbmx will only be true if in xtup that is NOT in explicit forced beam.
-c
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrest(ivx) = .false.
- infbmx(ivx) = .false.
- inxtup(ivx) = .false.
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv). The loop to 4
-c ONLY initializes each voice.
-c
- in = 1
- nxtup = 0
- narp = 0
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cwrferm(ivx) = .false.
- cnn(ivx) = 1
- ivxo(in) = ivx
- ipo(in) = cnn(ivx)
- tnote(in) = fnote(nodur,ivx,1,nacc)
- to(in) = 0.
- xit(ivx) = tnote(in)
-c
-c Note that xit(ivx) is to END of note in voice, but it1xtup is start time.
-c
- if (nodur(ivx,ipo(in)) .eq. 0) then
-c
-c First note of xtuplet at start of bar in voice ivx.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = 0.
-c
-c Xtup at start of bar. If no explicit forced beam, start one, set
-c signal infbmx, and save number ifbnow for use at termination.
-c
- if (nfb(ivx) .gt. 0) then
- do 60 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c No explicit fb here; so exit loop and insert one.
-c
- go to 61
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit fb here; must NOT insert one
-c
- go to 62
- end if
-60 continue
- end if
-61 continue
-c
-c If here, xtup isn't in explicit fb, so must insert one
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+
- * tglp1,t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-62 continue
- if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000.
- in = in+1
-4 continue
-c
-c Build the list: This is a manual loop starting at 5
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iiv = 1 , nv
- do 6 kv = 1 , nvmx(iiv)
- iivx = ivmx(iiv,kv)
- tminn = min(tmin,xit(iivx))
- if(tminn .lt. tmin-tol) then
- tmin = tminn
- ivx = iivx
- end if
-6 continue
- if (abs(tmin-1000.) .lt. tol) go to 7
- ivxo(in) = ivx
- cnn(ivx) = cnn(ivx)+1
- ipo(in) = cnn(ivx)
- to(in) = tmin
-c
-c Check if this voice is done
-c
- tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc)
- if (cnn(ivx) .eq. nn(ivx)) then
- xit(ivx) = 1000.
- else
- xit(ivx) = xit(ivx)+tnote(in)
- end if
-c
-c Flag xtups
-c
- if (nodur(ivx,cnn(ivx)) .eq. 0) then
- if (.not.inxtup(ivx)) then
-c
-c First note of xtup, not at start of bar.
-c
- nxtup = nxtup+1
- nxtnow(ivx) = nxtup
- inxtup(ivx) = .true.
- t1xtup(nxtup) = xit(ivx)-tnote(in)
-c
-c (Note: can't be on last note in voice, so xit(ivx) <> 1000)
-c Put xtuplet in a forced beam if not already in forced beam
-c
- if (nfb(ivx) .gt. 0) then
- do 70 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c NO explicit bm; put one in
-c
- go to 71
- else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
- * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
-c
-c IS explicit bm. Don't put one
-c
- go to 72
- end if
-70 continue
- end if
-71 continue
-c
-c If here, no explicit bm, so put one in
-c
- infbmx(ivx) = .true.
- call addfb(nfb,ivx,t1xtup(nxtup)+tglp1,
- * t1fb,t2fb,ulfbq,ifbadd)
- ifbnow(ivx) = ifbadd
- end if
-72 continue
- else if (inxtup(ivx)) then
-c
-c This test is sufficient because already know nodur>0
-c
- inxtup(ivx) = .false.
- if (infbmx(ivx)) then
-c
-c Xtup is in auto-forced beam, so end it
-c
- t2fb(ivx,ifbnow(ivx)) =
- * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1
- infbmx(ivx) = .false.
- end if
- end if
- if (btest(irest(ivxo(in),ipo(in)),24) .or.
- * btest(irest(ivxo(in),ipo(in)),30)) then
-c
-c For staff jumped beam, flag the first note (lowest voice) at same time.
-c Later will start new notes group here.
-c
- inj = in
- if (ivxo(in) .gt. 1) then
- do 40 iin = in-1 , 1 , -1
- if (to(iin)+tol .lt. to(in)) go to 41
- if (abs(to(iin)-to(in)) .lt. tol) then
- inj = iin
- go to 40
- end if
-40 continue
- end if
-41 continue
- irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29)
- end if
- in = in+1
- go to 5
-7 continue
- ntot = in-1
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = tnote(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(a)')' Greetings from PMXB'
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot)
-c
-c Done w/ list. Loop for parsing into note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c A manual loop to set space(ib) and istop(ib)
-c
-9 continue
-
- ivx = ivxo(min(in+1,ntot))
- ip = ipo(min(in+1,ntot))
- isl = islur(ivx,ip)
- if (in.eq.ntot .or. ((ivx.eq.1 .and.
- * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28)
-c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then
-c Bits 1-13: stmgx+Tupf._)
-c 14: Down fermata, was F
-c 15: Trill w/o "tr", was U
- * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) )
-c
-c Checking for start of 2nd part of jumped beam
-c
- * .or. btest(irest(ivx,ip),29) ) then
-c
-c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam;
-c flow out of if-loop and into block-wrapup
-c
-c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered
-c voice, but it wasn't first in the list at the same time. So check if
-c prior notes in list have same time
-c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef
-c changes on last note in the list?
-c
- if (btest(isl,15) .and. in.lt.ntot) then
- do 50 iin = in , 1 , -1
- if (tno(iin) .gt. tol) then
- in = iin
- islur(ivx,ip) = ibclr(islur(ivx,ip),15)
- islur(ivxo(in+1),ipo(in+1)) =
- * ibset(islur(ivxo(in+1),ipo(in+1)),15)
- go to 51
- end if
-50 continue
-51 continue
- end if
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
- squez(ib) = 1.
- end if
- istop(ib) = in
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the group, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart and istop are good, so finalize block
-c
- tstart(ib) = to(istart(ib))
- if (istop(ib) .eq. ntot) go to 15
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space and squeeze-factor for upcoming block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
- nb = ib
-c
-c Invert the list of places into ipl(0-7), making it easier to analyze a voice
-c
- do 13 in = 1 , ntot
-c
-c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes.
-c
-c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in)
- ipl2(ivxo(in),ipo(in)) = in
-13 continue
-c
-c Compute elemskips from start of bar to each note in the bar, for beam slopes
-c
- eskzb = 0.
- ib = 1
- do 30 in = 1 , ntot
- if (in .eq. istart(ib)) then
- deskb = squez(ib)*feon(space(ib)/squez(ib))
- else if (tno(in-1) .gt. tol) then
- eskzb = eskzb+deskb
- end if
- eskz(ivxo(in),ipo(in)) = eskzb
- eskz2(ivxo(in),ipo(in)) = eskzb
- if (in .eq. istop(ib)) then
- eskzb = eskzb+deskb
- ib = ib+1
- end if
-30 continue
-c
-c Debug writes
-c
-c print*
-c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot)
-c print*,'PMXB has now got blocks'
-c write(*,'(16i5)')(istart(ib),ib=1,nb)
-c write(*,'(16i5)')(istop(ib),ib=1,nb)
-c write(*,'(16f5.1)')(space(ib),ib=1,nb)
-c write(*,'(16f5.1)')(squez(ib),ib=1,nb)
-c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot)
-cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048,
-c * in=1,ntot)
-c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot)
-c
-c
-c Analyze for beams.
-c
- do 20 iv = 1 , nv
- do 20 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- numbms(ivx) = 0
- mapfb(1) = 0
- mapfb(2) = 0
- mapfb(3) = 0
- mapfb(4) = 0
-c
-c First forced beams.
-c
- if (nfb(ivx) .gt. 0) then
-c
-c tglp2 is time from start of gulp to end of current bar.
-c
- nfbbar = 0
- do 80 ifb = 1 , nfb(ivx)
- if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81
- nfbbar = nfbbar+1
- numbms(ivx) = numbms(ivx)+1
- numnew = numbms(ivx)
-c
-c Times from beginning of bar
-c
- itbb1 = int(t1fb(ivx,ifb)-tglp1+tol)
- itbb2 = int(t2fb(ivx,ifb)-tglp1+tol)
- do 83 ip = 1 , nn(ivx)
- if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then
- nip1fb = ip
- do 84 ip1 = ip , nn(ivx)
- inip1 = ipl2(ivx,ip1)
- if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then
- nip2fb = ip1
- itbb3 = itbb2-2
- go to 85
- end if
-84 continue
- end if
-83 continue
- print*
- print*,'Timing problem w/ forced beams'
- write(15,'(/a)')'Timing problem w/ forced beams'
-85 continue
- call logbeam(numnew,nip1fb,nip2fb)
-c
-c Set up mapfb for forced beam just logged:
-c
- ib1 = itbb1/2
- ib2 = itbb3/2
- ibrep = lenbar/ibmrep/2
- do 86 irep = 1 , ibmrep
- ib1now = max(0,ib1-(irep-1)*ibrep)
- ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep)
- mapnow = 0
- do 87 ib = ib1now , ib2now
- mapnow = ibset(mapnow,ib)
-87 continue
- mapfb(irep) = ior(mapfb(irep),mapnow)
-86 continue
-c
-c Since we are cycling thru forced beams, for those that start with a rest and
-c have height & slope adjustments, move adjustments to next note.
-c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at
-c start of beam
-c
- if (btest(irest(ivx,nip1fb),0)) then
-c call setbits(ipl(ivx,nip1fb+1),6,11,
-c * igetbits(ipl(ivx,nip1fb),6,11))
-c call setbits(ipl(ivx,nip1fb+1),6,17,
-c * igetbits(ipl(ivx,nip1fb),6,17))
-c call setbits(islur(ivx,nip1fb+1),2,27,
-c * igetbits(islur(ivx,nip1fb),2,27))
- do 88 kp = nip1fb+1 , nip2fb
- call setbits(ipl(ivx,kp),6,11,
- * igetbits(ipl(ivx,nip1fb),6,11))
- call setbits(ipl(ivx,kp),6,17,
- * igetbits(ipl(ivx,nip1fb),6,17))
- call setbits(islur(ivx,kp),2,27,
- * igetbits(islur(ivx,nip1fb),2,27))
-88 continue
- end if
-80 continue
-81 continue
-c
-c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar.
-c Remember, makeabar is called 1/bar, and it calls findbeam once per voice.
-c
- if (nfbbar .gt. 0) then
- nfb(ivx) = nfb(ivx)-nfbbar
- do 82 ifb = 1 , nfb(ivx)
- t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar)
- t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar)
- ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar)
-82 continue
- end if
- end if
- ifb = 0
-c
-c Done with forced beam masks for this bar and voice. Now get normal beams.
-c
- call findbeam(ibmrep,numbms,mapfb)
-20 continue
- return
- end
- subroutine make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
- parameter (nm=24,mv=24576)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*10 figq
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp,
- * isbj2
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /combeam/ ibmtyp
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,issig,rpndot,autofbon
- character*128 litq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- integer istart(80),istop(80),iaskb(nm),numbms(nm),
- * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2)
- character*1 ulfbq,udqq,clefq(nm),slurudq
- character*8 noteq
- character*79 cwrq(nm),notexq,inameq
- character*20 voltxtq
- common /comoct/ noctup
- character*80 soutq,headrq,lowerq
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- logical bspend,lower,cwrest(nm),vxtup,
- * isgrace,isclef,nofirst,iscln,isdot,isflag,
- * isacc,isfirst,flgndb,btest,stemup,upslur,
- * isgaft,isarp,isrshft,isaccs,iscacc,
- * lowdot,flipend,iscwr,isdotted,beamon1(nm)
- real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80),
- * squez(80)
- logical cwrferm,drawbm
- common /comcwrf/ cwrferm(nm)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xelsk(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /comstart/ facmtr
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
-c
-c Factors for grace note, clef spacing. (fraction of wheadpt)
-c In 1.04, moved to block data subprogram
-c
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comtol/ tol
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur
- * ,WrotePsslurDefaults
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- logical slmon,dbltie
- common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
- * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
- * slmon(0:nm),dbltie
- common /comevent/ miditime,lasttime
- logical kbdrests
- common /comkbdrests/ levbotr(8),levtopr(8),kbdrests
- logical secondgrace
-c
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
-c
-c
-c Set up main ib loop within which a block (notes group) is written
-c
- do 25 iv = 1 , nv
- do 25 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ibmcnt(ivx) = 1
- ibmcnt1(ivx) = 1
- beamon(ivx) = .false.
- beamon1(ivx) = .false.
- nornb(ivx) = 0
- iaskb(ivx) = 1
- vxtup(ivx) = .false.
- drawbm(ivx) = .true.
-25 continue
- naskb = 0
- ifig(1) = 1
- ifig(2) = 1
- ixtup = 0
- bspend = .false.
- iscwr = .false.
- rpndot = .false.
- do 16 ib = 1 , nb
-c
-c Check for segno
-c
- if (btest(iornq(1,ipo(istart(ib))),4) .and.
- * ivxo(istart(ib)).eq.1) then
- if (noffseg.le.-10) then
- write(noteq(1:5),'(1H{,i3,1H})')noffseg
- lnoten = 5
- else if (noffseg.lt.0 .or. noffseg.ge.10) then
- write(noteq(1:4),'(1H{,i2,1H})')noffseg
- lnoten = 4
- else
- write(noteq(1:1),'(i1)')noffseg
- lnoten = 1
- end if
- notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9'
- lnote = 15+lnoten
- do 130 iv = 2 , nv
- if (lnote .gt. 60) then
- if (islast) write(11,'(a)')notexq(1:lnote)//'%'
- notexq = sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnoten+9
- else
- notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo'
- * //noteq(1:lnoten)//'9'
- lnote = lnote+lnoten+9
- end if
-130 continue
- if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en'
- lnote = 0
- end if
-c
-c Check for new clefs
-c
- isclef = .false.
- if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15))
- * then
-c
-c In preceding line, fl32 gave wrong result for ... .gt.0 !!!
-c
- do 140 in = istart(ib) , istop(ib)
- if (btest(islur(ivxo(in),ipo(in)),11)) then
- call wsclef(ivxo(in),ninow,clefq,
- * iand(ishft(islur(ivxo(in),ipo(in)),-12),7))
- end if
-140 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- isclef = .true.
- end if
-c
-c Start a notes group. We're just gonna define every one using pnotes{n},
-c where \def\pnotes#1{\vnotes#1\elemskip}
-c
- soutq = sq//'pnotes{'
- eonsqz = squez(ib)*feon(space(ib)/squez(ib))
- if (eonsqz .gt. 9.995) then
- write(soutq(9:12),'(f4.1)')eonsqz
- else if (eonsqz .gt. 0.995) then
- write(soutq(9:12),'(f4.2)')eonsqz
- else if (eonsqz .gt. 0.095) then
- soutq = soutq(1:8)//'0.'
- write(soutq(11:12),'(i2)')nint(100*eonsqz)
- else
- soutq = soutq(1:8)//'0.0'
- write(soutq(12:12),'(i1)')nint(100*eonsqz)
- end if
- soutq = soutq(1:12)//'}'
- lsout = 13
-c
-c Check whole block, flag accidentals etc that are too close, one per *time*.
-c Note about bar starts and after rpt's/boublebars: There is an afterruleskip
-c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so
-c (dotsfac*wheadpt) is presumed to be filled up.
-c
- in = istart(ib)-1
- itrpt = -1
- itsig = -1
-c
-c Begin big manual loop over notes in this block; ends at 112
-c
-111 in = in+1
- if (in .gt. istop(ib)) go to 112
- ip = ipo(in)
- ivx = ivxo(in)
- if (ivx .le. nv) then
- iv = ivx
- else
- do 128 iv = 1 , nv
- if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129
-128 continue
- print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2)
- print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2)
- stop
- end if
-129 continue
-c
-c Call precrd here so we know how much space to add for accid's in chords
-c After calling precrd, icashft>0 means there is a shifted chordal accid (incl.
-c main note.
-c
-c To call precrd, need up-downness, so must track if in beam.
-c
-c Deal w/ staff-jumping beams later
-c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
-c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
-c * btest(nacc(ivx,ip),21)) then
-c if (.not.btest(irest(ivx,ip),24)) then
- if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then
- beamon1(ivx)=.true.
- end if
- icashft = 0
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds.
-c
- if (beamon1(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)),
- * .false.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .false.,icashft)
- end if
- end if
-c
-c Turn beam off?
-c
- if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then
- beamon1(ivx) = .false.
- ibmcnt1(ivx) = ibmcnt1(ivx)+1
- end if
-c
-c Remember, rpts & internal sigs can only come at start of (internal) block
-c
- isacc = iand(nacc(ivx,ip),3).gt.0
- * .and. .not.btest(nacc(ivx,ip),17)
- * .and. .not.btest(ipl(ivx,ip),10)
-c
-c i.e., do not set for chord. Now check for "(" as ornament on main note,
-c
-c!!! Need to do this for chord notes too. Maybe in chkarp?
-c
- isaccs = isacc .or. btest(iornq(ivx,ip),0)
-c
-c 5/15/02 Add check for ) ornament of prior note.
-c 5/16 Nope...fails when grace intervenes.
-c if (ip .gt. 1) then
-c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13)
-c end if
- isarp = btest(iornq(ivx,ip),27)
- iscacc = .false.
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord here; check for arpeggios and accidentals. Note accid shifts are
-c not of concern here, only whether there's an accid, whick causes iscacc=.true.
-c
- iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)
- call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp)
- end if
-c
-c When we get motivated, will do spacing for arpeggios here.
-c
- if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0)
- * itrpt = nint(to(in))
- issig = btest(ipl(ivx,ip),28)
- if (ivx.eq.1 .and. issig) itsig = nint(to(in))
- isgrace = btest(islur(ivx,ip),4) .and.
- * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31)
- isgaft = .false.
- if (ip .gt. 1) then
- xnd = tnote(ipl2(ivx,ip-1))
- isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31)
- isgrace = isgrace .or. isgaft
- end if
- iscln = isclef .and. btest(islur(ivx,ip),11)
-c
-c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd
-c
- isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol
- if (isflag)
- * isflag = .not.btest(irest(ivx,ip-1),0)
- * .and. udqq(nolev(ivx,ip-1),
- * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u'
- if (isflag) then
- do 116 ibmchk = 1 , numbms(ivx)
- if (ip-1 .lt. ibm1(ivx,ibmchk)) then
- go to 117
-c
-c Add check for non-beamed xtuplets. May be problem with stem direction.
-c
-c else if (ip-1.le.ibm2(ivx,ibmchk)) then
- else if (ip-1.le.ibm2(ivx,ibmchk) .and.
- * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then
- isflag = .false.
- go to 117
- end if
-116 continue
- end if
-117 continue
-c
-c If isflag, then won't need to check for dot on prev. note.
-c
-c 5/16/02 ??? Try using this for ) ornament.
-c
- isflag = isflag .or. btest(iornq(ivx,ip-1),13)
- isdot = ip.gt.1
- if (isdot) isdot = isdotted(nodur,ivx,ip-1)
- isrshft = ip .gt. 1
- if (isrshft) isrshft = btest(irest(ivx,ip-1),20)
- if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or.
- * isdot.or.btest(iornq(ivx,ip),26).or.
- * btest(irest(ivx,ip),21).or.isarp.or.
- * btest(irest(ivx,ip),27).or.iscacc)) go to 111
-c
-c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift.
-c Compute pts, the total occupied space including prior notehead.
-c
- wheadpt1 = wheadpt*fullsize(iv)
- pts = wheadpt1
-c
-c Set up for possible cautionary accidental here
-c
- if (isaccs .or. iscacc) then
- if (.not.btest(iornq(ivx,ip),31)) then
- taccfac = accfac
- else
- taccfac = 1.4*accfac
- end if
- end if
- if (isgrace) then
- secondgrace = .false.
- do 122 ig = 1 , ngrace
- if (.not. isgaft) then
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123
- else if (ip .gt. 1) then
- if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123
- end if
-122 continue
- print*,'Problem finding grace index in makeabar'
- stop
-123 continue
-c
-c wgr = distance to backspace (in headwidths), less main acc.
-c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace.
-c spgr = total space needed (w/o main acc).
-c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place.
-c
- if (nng(ig) .eq. 1) then
- wgr = grafac
- if (multg(ig) .eq. 0) wgr = wgr-.4
- else
- wgr = nng(ig)*emgfac
- do 126 ing = 2 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-126 continue
- end if
- if (graspace(ig) .gt. 0.) then
-c
-c User-defined space before grace
-c
- wgr = wgr+graspace(ig)
- end if
- ptgr(ig) = wgr*wheadpt1
- spgr = ptgr(ig)+xb4fac*wheadpt1
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1
- if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac
- pts = pts+spgr
-c
-c Special check for after-grace on ip-1 and normal on ip. Must go back thru
-c loop again for the normal grace.
-c
- if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then
- if (ipg(ig+1).eq.ip) then
- secondgrace = .true.
- ig = ig+1
- go to 123
- end if
- end if
- end if
- if (iscln) then
- pts = pts+clefac*wheadpt1
-c
-c How far to backspace when printing the clef
-c
- ptclef(ivx) = 0.
-c
-c!!! May need to mod for chord accid's
-c
- if (isaccs .or. iscacc)
- * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1
- if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
- end if
- if (isrshft) then
- pts = pts+rtshfac*wheadpt1
- else if (isflag) then
- pts = pts+flagfac*wheadpt1
- else if (isdot) then
- pts = pts+dotfac*wheadpt1
- end if
- if (abs(to(in)-itrpt) .lt. tol) then
-c
-c Repeat, need a little extra space
-c
- pts = pts+dotsfac*wheadpt1
- end if
- if (isarp) then
- pts = pts+arpfac*wheadpt1
- end if
-c
-c Add in padding space
-c
- pts = pts+xspfac*wheadpt1
-c
-c Now done with all items needing space except accidentals,
-c accidental shifts, and left-notehead-shifts, and will later
-c subtract a notehead if at start of bar.
-c
-c Get available space in elemskips (esk)
-c
-c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or.
-c * to(in) .eq. itsig
- isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or.
- * abs(to(in)-itsig).lt.tol
- if (isfirst) then
-c
-c At start of bar or after repeat sign or new signature
-c
-c if (to(in) .eq. itsig) then
- if (abs(to(in)-itsig).lt.tol) then
- esk = 0.
- else
- esk = fbar
- end if
- else
-c
-c Not 1st note of bar
-c
- esk = eskz(ivx,ip)-eskz(ivx,ip-1)
- end if
- if (isgrace) then
-c
-c Since graces can be very long, cannot assume no interference if prior
-c note uses >1 noteskip. So must get elsk's back to prior note, whether or
-c not it used only one noteskip.
-c <<But if it was xtup. don't need to call eskb4.>>????
-c
-c 10/8/05 Kluge to not zero out esk if in xtup
-c
- esksav = esk
- if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and.
-c * to(in).ne.itsig)
- * abs(to(in)-itsig).gt.tol)
- * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
- if (abs(esk) .lt. tol) esk = esksav
- end if
-c
-c Done getting available elemskips. Remove headwidth if first. Must do here
-c rather than earlier since check uses isfirst
-c
- if (isfirst) pts = pts-wheadpt1
-c
-c Deal with accidental shifts and left-notehead shifts
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c In a chord
-c
- ptsl = 0.
- if (btest(irest(ivx,ip),27)) ptsl = wheadpt1
- ptsadd = max(ptsl,icashft*.05*wheadpt1)
-c
-c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK
-c
- else
-c
-c Not in a chord
-c
- ihshft = 0
- if (isaccs) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
-c if (ihshft .ne. 0) ihshft = max(0,64-ihshft)
- if (ihshft .ne. 0) ihshft = max(0,107-ihshft)
- end if
-c
-c Check for left-shifted main note
-c
- if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft)
- ptsadd = ihshft*.05*wheadpt1
- end if
- pts = pts+ptsadd
- if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd
- if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd
-c
-c Left-shifted, non-chord note before?
-c
- if (ip .gt. 1) then
- if (.not.btest(ipl(ivx,ip-1),10) .and.
- * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1
- end if
-c
-c Try big accidentals first
-c
- ptbneed = pts
- if (isaccs .or. iscacc) then
- ptbneed = ptbneed+wheadpt1*bacfac
- end if
- if (poenom*esk .gt. ptbneed) then
-c
-c Set flag for big accidental
-c
- if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3)
- go to 99
- end if
-c
-c Cannot use big, so try small
-c
- ptsneed = pts
- if (isaccs .or. iscacc) then
- ptsneed = ptsneed+taccfac*wheadpt1
- end if
- if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed,
- * esk,fixednew,scaldold,0.,.false.)
-99 continue
- if (btest(iornq(ivx,ip),26)) then
-c
-c User-defined space. Warning, "zero" may change value in addask!
-c
- zero = 0.
- call addask(to(in),ptsneed,zero,
- * fixednew,scaldold,tglp1,.true.)
- end if
-c
-c End of big manual loop over "in" for accidental checking
-c
- go to 111
-112 continue
-c
-c End of ask analysis for this block.
-c
-c Adjust eskz if there are added spaces. Corrects length of xtup brackets.
-c
- if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom)
-c
-c Check for internal repeat or sig change.
-c
- if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then
- iirpt = iand(islur(1,ipo(istart(ib))),67109216)
- if (iirpt .gt. 0) then
-c
-c Internal repeat
-c
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (iirpt .eq. 96) then
- if (islast) write(11,'(a)')sq//'leftrightrepeat'
- fixednew = fixednew+lrrptfac*wheadpt
- else if (btest(iirpt,5)) then
- if (islast) write(11,'(a)')sq//'leftrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,6)) then
- if (islast) write(11,'(a)')sq//'rightrepeat'
- fixednew = fixednew+rptfac*wheadpt
- else if (btest(iirpt,8)) then
- if (islast) write(11,'(a)')sq//'doublebar'
- else
- print*,'Unexpected mid-bar repeat command R*'
- call stop1()
- end if
- scaldold = scaldold-fbar
- end if
- if (btest(ipl(1,ipo(istart(ib))),28)) then
-c
-c Internal signature change.
-c
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:lnote)//'-'
- lnote = lnote+1
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'//sq//'afterruleskip}%'
- lnote = 0
- end if
- end if
- flgndb = .false.
-c
-c Done with start-of-block stuff. Begin main loop over voices.
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- icm = midchan(iv,kv)
-c
-c A rather klugey way to set flag for figure in this voice
-c Must always check figbass before figchk.
-c
- if (figbass) then
- ivf = 0
- if (ivx .eq. 1) then
- ivf = 1
- else if (ivx .eq. ivxfig2) then
- ivf = 2
- end if
- if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0
- end if
- if (ivx .gt. 1) then
- if (ivx .le. nv) then
- call addstr(sepsymq(iv-1),1,soutq,lsout)
- else
- call addstr(sq//'nextvoice',10,soutq,lsout)
- end if
- end if
- if (ihdht.gt.0 .and. ivx.eq.nv) then
-c
-c Write header. First adjust height if needed to miss barno.
-c
- if (bar1syst .and. iline.ne.1) then
- ihdht = 15+irzbnd+isnx
- end if
-c
-c Add user-defined vertical shift
-c
- ihdht = ihdht+ihdvrt
- lchead = lenstr(headrq,80)
- notexq = sq//'zcharnote{'
- write(notexq(12:13),'(i2)')ihdht
- notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt '
- call addstr(notexq,34,soutq,lsout)
- call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout)
- ihdht = 0
- end if
- if (lower .and. ivx.eq.nv) then
- lclow = lenstr(lowerq,80)
- call addstr(sq//'zcharnote{-6}{'//
- * sq//'tempo'//sq//'kern-10pt '//
- * lowerq(1:lclow)//'}',33+lclow,soutq,lsout)
- lower=.false.
- end if
- tnow = tstart(ib)
- nofirst = .true.
-c
-c Done setting up voice ivx for start of block ib. Loop over notes in voice.
-c
- do 10 jn = istart(ib), istop(ib)
- if (ivxo(jn) .ne. ivx) go to 10
- ip = ipo(jn)
-c
-c May have problem with not initializing islhgt, so do it here
-c
- islhgt = 0
-c
- if (nofirst) then
- noctup = 0
- if (ncmid(iv,ip) .eq. 23) noctup = -2
- nofirst = .false.
- end if
-c
-c Check for internal floating figure (before last note of group).
-c
-12 if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol)
- * then
-c
-c Bypassed figure location. Backup, place fig, return.
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,
- * lsout)
- go to 12
- end if
- end if
- end if
-c
-c Put in \sk if needed
-c
- if (to(jn) .gt. tnow+tol) then
- call addstr(sq//'sk',3,soutq,lsout)
- tnow = tnow+space(ib)
- go to 12
- end if
-c
-c Check for user-defined shifts
-c
- if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16))
- * call putshft(ivx,.true.,soutq,lsout)
-21 if (iaskb(ivx).le.naskb .and.
- * tnow.gt.task(iaskb(ivx))-tol) then
- if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then
-c
-c Insert placeholder for accidental skip
-c
- call addstr(sq//'ask ',9,soutq,lsout)
- nasksys = nasksys+1
- wasksys(nasksys) = wask(iaskb(ivx))
- if (wask(iaskb(ivx)) .gt. 0.) then
- elasksys(nasksys) = elask(iaskb(ivx))
- else
-c
-c This is a signal to permit negative ask's. Should really have elask>=0.
-c
- elasksys(nasksys) = -elask(iaskb(ivx))
- end if
- end if
-c
-c May have skipped some task's in earlier blocks (due to void voice)
-c
- iaskb(ivx) = iaskb(ivx)+1
- go to 21
- end if
- if (figbass) then
- if (ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
- if (figchk(ivf) .and.
- * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then
-c
-c Figure on a note. NB: later special check for late figs.
-c
- call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout)
- end if
- end if
- end if
-c
-c Check for new clef here.
-c
- if (isclef .and. btest(islur(ivx,ip),11)) then
-c print*,'At clef insertion, ptclef:',ptclef(iv)
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{-'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(7:9),'(f3.1)')ptclef(iv)
- lnote = 9
- else
- write(notexq(7:10),'(f4.1)')ptclef(iv)
- lnote = 10
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
-c print*,'Just added: ',notexq(1:lnote)
- end if
- call clefsym(islur(iv,ip),notexq,lnote,nclef)
- call addstr(notexq,lnote,soutq,lsout)
- if (ptclef(iv) .gt. 0.) then
- notexq = sq//'off{'
- if (ptclef(iv) .lt. 9.95) then
- write(notexq(6:8),'(f3.1)')ptclef(iv)
- lnote = 8
- else
- write(notexq(6:9),'(f4.1)')ptclef(iv)
- lnote = 9
- end if
- notexq = notexq(1:lnote)//'pt}'
- lnote = lnote+3
- call addstr(notexq,lnote,soutq,lsout)
- end if
- end if
-c
-c Checking for literal TeX string BEFORE starting beams!!
-c
- if (btest(islur(ivx,ip),16)) then
- do 124 il = 1 , nlit
- if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125
-124 continue
- print*,'Problem finding index for literal string'
- call stop1()
-125 continue
-c
-c Write a type 1 tex string.
-c
- if (lenlit(il) .lt. 71) then
-c
-c Add normally
-c
- call addstr(litq(il),lenlit(il),soutq,lsout)
- else
-c
-c Longer than 71. Write souq, Write string, start new soutq.
-c
- if (islast) write(11,'(a)')soutq(1:lsout)//'%'
- if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%'
- lsout = 0
- end if
- end if
-c
-c Arpeggio on a main (non-chordal) note?
-c
- if (btest(iornq(ivx,ip),27)) then
-c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip),
- call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip),
- * soutq,lsout)
- end if
-c
-c See if a beam starts here
-c
- if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
- * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or.
- * btest(nacc(ivx,ip),21)) then
- if (.not.btest(irest(ivx,ip),24)) then
-c
-c Not a jump start
-c
- call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
-c
-c Shift beam start if notehead was shifted
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout)
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
- else
-c
-c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set
-c to 0 at end of first part of jump beam
-c
- ivbj2 = ivx
-c
-c Check for xtup since we bypassed beamstrt wherein vxtup is normally set
-c
- if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2)
- * vxtup(ivx) = .true.
-c
-c Since beamstrt is not called, and drawbm is normally set there, need to set
-c it here. This could cause problems if someone tries a staff-jumping,
-c unbarred beam, which I'll deal with when it comes up.
-c
- drawbm(ivx) = .true.
- end if
- if (ixrest(ivx) .eq. 0) then
- beamon(ivx) = .true.
- bspend = .true.
- if (.not.btest(irest(ivx,ip),24))bspend = .true.
- end if
- end if
-c
-c Setup for chords and possible slurs in chords
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c There is a chord on this note. Just rerun precrd. Klunky, but saves
-c me from tracking down errors instroduced when I moved 1st call
-c forward for accidental spacing analysis.
-c
- if (beamon(ivx)) then
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)),
- * .true.,icashft)
- else
- call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip),
- * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip),
- * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv),
- * .true.,icashft)
- end if
- end if
-c
-c Is there slur or grace activity?
-c
- isgrace = btest(islur(ivx,ip),4)
- if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31)
-c
-c isgrace if not 1st note in bar and previous note has Way-after grace.
-c
- if (btest(islur(ivx,ip),0) .or. isgrace) then
- if (btest(islur(ivx,ip),0)) then
- if (fontslur) then
-c
-c Call routine for non-postscript slurs
-c
- call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- else
-c
-c Postscript slurs
-c
- call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3,
- * isdat4,nsdat,
- * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
- * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
- * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)),
- * nacc(ivx,ip))
- end if
- end if
- if (isgrace) then
-c
-c Grace note.
-c
- iphold = ip
- isgrace = .false.
- if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31)
- if (isgrace) iphold = iphold-1
- isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31)
- * .and..not.btest(ipl(ivx,ip),29))
-c
-c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace
-c on current note. Do A-grace on current note, and W-grace at barend, later.
-c
- if (isgrace) then
- call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,iphold),.false.,
- * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx),
- * tnote(ipl2(ivx,ip)),ulq)
- if (slurg(ig)) then
-c
-c Terminate slur started in dograce. Get direction of main note stem
-c
- if (.not.beamon(ivx)) then
-c
-c Separate note. Get stem direction.
-c
- stemup = udqq(nolev(ivx,ip),ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u'
- else
-c
-c In a beam
-c
- stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u'
- end if
-c
-c Stop the shift if whole note
-c
- stemup = stemup .or.
- * tnote(ipl2(ivx,ip)).gt.63
- call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0,
- * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur)
- end if
- end if
- end if
- if (btest(iornq(ivx,ip),24)) then
-c
-c Start slur on main note for After- or Way-after-grace.
-c
-c???? ndxslur = log2(33554431-listslur)
- ndxslur = log2(16777215-listslur)
-c
-c Get note name
-c
- call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
-c
-c Get slur direction
-c
- slurudq = 'u'
- if (.not.beamon(ivx)) then
- if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd'
- else
- if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd'
- end if
-c
-cc Replace ndxslur by 11-ndxslur when printing only.
-c Replace ndxslur by 23-ndxslur when printing only.
-c
-c if (11-ndxslur .lt. 10) then
- if (23-ndxslur .lt. 10) then
-c notexq = sq//'islur'//slurudq//chax(59-ndxslur)
- notexq = sq//'islur'//slurudq//chax(71-ndxslur)
- * //noteq(1:lnoten)
- call addstr(notexq,8+lnoten,soutq,lsout)
- else if (23-ndxslur .lt. 20) then
- notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- else
- notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur)
- * //'}'//noteq(1:lnoten)
- call addstr(notexq,11+lnoten,soutq,lsout)
- end if
-c call setbits(ipl(ivx,ip),4,23,ndxslur)
- call setbits(ipl(ivx,ip),5,23,ndxslur)
- if (btest(ipl(ivx,ip),31))
-c
-c Starting slur on W-grace on THIS note. Record ndxslur.
-c
- * listslur = ibset(listslur,ndxslur)
- end if
- end if
-c
-c Process dynamic marks
-c
- if (btest(irest(ivx,ip),26)) then
- call dodyn(ivx,ip,
- * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip),
- * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq,
- * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout)
- end if
-c
-c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st.
-c
- if (btest(ipl(ivx,ip),10)) then
-c
-c Need a duration to set type of note head
-c
-c if (.not. vxtup(ivx)) then
-c
-c Clumsy test, but vxtup is not set until main note is processed.
-c
- if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then
- nodu = nodur(ivx,ip)
-c else if (mult(ivx,ip) .lt. 0) then
- else if (iand(mult(ivx,ip),15)-8 .lt. 0) then
- nodu = 32
- else
- nodu = 16
- end if
- call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout,
- * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv,
- * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen,
- * btest(nacc(ivx,ip),27),nacc(ivx,ip))
- end if
-c
-c Now that chords are done, add stuff to midi file
-c
-c if (ismidi) call addmidi(icm,nolev(ivx,ip),
- if (ismidi) call addmidi(icm,
- * nolev(ivx,ip)-iTransAmt(instno(iv)),
-c
- * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)),
- * btest(irest(ivx,ip),0),.false.)
-c
-c Check for breath or caesura
-c
- if (btest(iornq(ivx,ip),28)) then
- call putcb(ivx,ip,notexq,lnote)
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Check for main-note ornaments. ')' on dotted notes go in with note, not here.
-c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F
-c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD
-c
- isacc = iand(iornq(ivx,ip),4194287) .gt. 0
-c
-c isacc=.true. if any ornament except segno
-c
- if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then
-c
-c If ). is only ornament, bypass. If with others, temporarirly zero the bit.
-c
- if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
- if (iand(iornq(ivx,ip),516079) .eq. 0) then
-c
-c ). is the only non-segno ornament
-c
- isacc = .false.
- else
-c
-c There are other ornaments in addition
-c
- rpndot = .true.
- iornq(ivx,ip) = ibclr(iornq(ivx,ip),13)
- end if
- end if
- end if
- if (isacc .and. .not.cwrferm(ivx)) then
-c
-c Check for centered whole-bar rest with fermata (bits 10 or 14).
-c
- if (iand(iornq(ivx,ip),17408).gt.0
- * .and. btest(irest(ivx,ip),0) .and.
- * nodur(ivx,ip).eq.lenbar .and.
- * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
- cwrferm(ivx) = .true.
- go to 30
- end if
- call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip),
- * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen,
- * notexq,lnote,ip,islhgt,beamon(ivx),
- * btest(ipl(ivx,ip),10))
- call addstr(notexq,lnote,soutq,lsout)
- end if
- if (rpndot) then
- iornq(ivx,ip) = ibset(iornq(ivx,ip),13)
- rpndot = .false.
- end if
-30 continue
-c
-c Check for main note accidental
-c
- if (iand(nacc(ivx,ip),3).gt.0 .and.
- * .not.btest(nacc(ivx,ip),17)) then
- ihshft = igetbits(nacc(ivx,ip),7,10)
- if (ihshft .ne. 0) ihshft=ihshft-107
- if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8))
-c
-c Not a chord, and left-shifted main note, so left-shift accid
-c
- * ihshft = ihshft-20
- call doacc(ihshft,igetbits(nacc(ivx,ip),6,4),
- * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip),
- * btest(irest(ivx,ip),31))
- call addstr(notexq,lnote,soutq,lsout)
- end if
-c
-c Lower dot for lower-voice notes. Conditions are:
-c 1. Dotted time value
-c 2. Lower voice of two
-c 3. Note is on a line
-c 4. Not a rest
-c. 5. Flag (lowdot) is set to true
-c 6. Not in an xtuplet
-c
- if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv
- * .and. nodur(ivx,ip).ne.0) then
- if (.not.btest(irest(ivx,ip),0) .and.
- * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and.
- * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then
- if (btest(irest(ivx,ip),19)) then
-c
-c Note already in movdot list. Drop by 2.
-c
- updot(ivx,ndotmv(ivx)+1) =
- * updot(ivx,ndotmv(ivx)+1)-2.
- else
-c
-c Not in list so just move it right now
-c
- call dotmov(-2.,0.,soutq,lsout,
- * igetbits(islur(ivx,ip),1,3))
- end if
- end if
- end if
-c
-c Check for dotted notes with moved dots
-c
- if (btest(irest(ivx,ip),19)) then
- ndotmv(ivx) = ndotmv(ivx)+1
- call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)),
- * soutq,lsout,igetbits(islur(ivx,ip),1,3))
- end if
-c
-c Stemlength shortening?
-c
- if (btest(mult(ivx,ip),27)) then
- stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5
- call addstr(sq//'stemlength{',12,soutq,lsout)
- write(notexq,'(f4.2)')stemshort
- call addstr(notexq(1:4)//'}',5,soutq,lsout)
- else if (ip .gt. 1) then
- if (btest(mult(ivx,ip-1),27))
-c
-c Cancel shortening. Looks like it gets automatically restored if new inst. or
-c new line, so no need to worry about affecting other lines
-c
- * call addstr(sq//'stemlength{4.66}',17,soutq,lsout)
- end if
-c
-c Zero out slur-height marker for raising ornaments
-c
- islhgt = 0
-c
-c Now start with spacing notes. Is a beam start pending?
-c
- if (bspend .and.
- * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then
- if (ixrest(ivx) .eq. 4) then
-c
-c Special path for single note at end of otherwise beamed xtup
-c
- ixrest(ivx) = 0
- else
- call beamn1(notexq,lnote)
- end if
- bspend = .false.
-c
-c Is a beam ending?
-c
- else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
-c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then
- * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or.
- * btest(nacc(ivx,ip),20))) then
- if (bspend) then
-c
-c Must be a single-note ending of a jump-beam
-c
- bspend = .false.
- end if
- call beamend(notexq,lnote)
- if (.not.btest(nacc(ivx,ip),20)) then
- vxtup(ivx) = .false.
- nornb(ivx) = 0
- ibmcnt(ivx) = ibmcnt(ivx)+1
- beamon(ivx) = .false.
- end if
-c
-c Or if we're in the middle of a beam
-c
- else if (numbms(ivx).gt.0 .and. beamon(ivx)) then
- call beamid(notexq,lnote)
-c
-c Or whole-bar rest
-c
- else if (btest(irest(ivx,ip),0)
- * .and. nodur(ivx,ip).eq.lenbar
- * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)
- * .and..not.btest(irest(ivx,ip),25)
- * .and..not.btest(islur(ivx,ip),29)) then
-c
-c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp
-c
- cwrest(ivx) = .true.
- iscwr = .true.
- call notex(cwrq(ivx),lcwr(ivx))
- tnow = tnow+lenbar
- go to 10
- else if (ixrest(ivx) .eq. 0) then
-c
-c Before writing note or rest, check for keyboard rest height adjustment.
-c Conditions are 0. This is a non-blank rest
-c 1. kbdrests = .true.
-c 2. There are two voices on the staff
-c 3. No user-def height adjustments have been applied (nolev<50)
-cc 4. Not last note in bar
-cc 5. Followed by note (add better test later)
-c
- if (kbdrests .and. btest(irest(ivx,ip),0) .and.
- * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and.
-c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx)
-c * .and. .not.(btest(irest(ivx,ip+1),0))) then
- * nolev(ivx,ip).le.50) then
-c
-c Get reference level: next following note if no intervening blank rests,
-c otherwise next prior note.
-c
-c levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line
- if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then
-c
-c Not the last note and not "look-left" for level
-c
- do 8 kkp = ip+1 , nn(ivx)
- if (btest(islur(ivx,kkp),29)) go to 4
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-8 continue
- end if
-4 continue
-c
-c If here, there were no following notes or came to a blank rest, or
-c "look-left" option set. So look before
-c
- if (ip .eq. 1) go to 2 ! Get out if this is the first note.
- do 3 kkp = ip-1, 1, -1
- if (.not.btest(irest(ivx,kkp),0)) then
- levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line
- go to 9
- end if
-3 continue
- go to 2 ! Pretty odd, should never be here, but get out if so.
-9 continue
-c
-c Find note in other voice at same time
-c
- iupdown = sign(1,ivx-nv-1)
- ivother = ivmx(iv,(3-iupdown)/2)
- tother = 0.
- do 5 kkp = 1 , nib(ivother,ibar)
- if (abs(tother-tnow) .lt. tol) go to 6
- tother = tother+nodur(ivother,kkp)
-5 continue
-c
-c If here, then no note starts in other voice at same time, so set default
-c
- levother = -iupdown*50
- go to 7
-6 continue
-c
-c If here, have just identified a simultaneous note or rest in other voice
-c
- if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it
- levother = nolev(ivother,kkp)-ncmid(iv,ip)+4
- else
- if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then
-c
-c Rest in other voice has same duration, get out (so defualt spacing is used)
-c
- go to 2
- end if
- levother = -iupdown*50
- end if
-7 continue
- indxr = log2(nodur(ivx,ip))+1
- if (iupdown .lt. 0) then
- levtop = levtopr(indxr)
- iraise1 = levother-levtop-3 ! Based on other note
- iraise2 = levnext-levtop ! Based on following note
- if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2
- iraise = min(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levtop.gt.-1) iraise = iraise-1
- else
- levbot = levbotr(indxr)
- iraise1 = levother-levbot+3
- iraise2 = levnext-levbot
- if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1
- iraise = max(iraise1,iraise2)
- if (mod(iraise+50,2).eq.1 .and.
- * iraise+levbot.le.9) iraise = iraise-1
- end if
- nolev(ivx,ip) = 100+iraise
- end if
-2 continue
-c
-c Write a separate note or rest
-c
- call notex(notexq,lnote)
- end if
-c
-c Right offset? This may cause trouble
-c
- if (btest(ipl(ivx,ip),8)) then
- call addstr(sq//'loff{',6,soutq,lsout)
- else if (btest(ipl(ivx,ip),9)) then
- call addstr(sq//'roff{',6,soutq,lsout)
- end if
- if (ixrest(ivx).eq.0 .and. lnote.gt. 0)
- * call addstr(notexq,lnote,soutq,lsout)
- if (btest(ipl(ivx,ip),8) .or.
- * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
-c
-c Terminate user-defined offsets. Fix format
-c
- if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17))
- * call putshft(ivx,.false.,soutq,lsout)
-c
-c Deal with After- and Way-after-graces. First, if end of bar, compute space
-c needed since it wasn't done during general ask-checks. If extra space is
-c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp.
-c But will still need to add extra space as hardspace.
-c
- if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or.
- * btest(ipl(ivx,ip),29))) then
- do 77 ig = 1 , ngrace
- if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78
-77 continue
- print*,'Problem finding grace index at "do 77"'
- call stop1()
-78 continue
-c
-c Get elemskip to end of bar. WON'T WORK IF XTUPS !!
-c
- esk = 0.
- do 40 iib = ib , nb
- if (iib .eq. ib) then
- itleft = nint(to(ipl2(ivx,ip)))
- else
- itleft = nint(tstart(ib))
- end if
- if (iib .lt. nb) then
- itright = nint(tstart(iib+1))
- else
- itright = lenbar
- end if
- esk = esk+feon(space(ib))*
- * (itright-itleft)/space(ib)
-40 continue
- ptsavail = poenom*esk-wheadpt
- if (nng(ig) .eq. 1) then
- wgr = grafac
- else
- wgr = nng(ig)*emgfac
- do 41 ing = 1 , nng(ig)
- if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
-41 continue
- end if
- ptgr(ig) = wgr*wheadpt
- ptsneed = (wgr+0.5)*wheadpt
- ptsndg(ivx) = 0.
- if (ptsavail .lt. ptsneed) then
- ptsndg(ivx) = ptsneed
- eskndg(ivx) = esk
- if (btest(ipl(ivx,ip),31)) then
-c
-c Convert GW to GA
-c
- ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29)
- end if
- end if
- end if
-c
-c Check for GA
-c
- if (btest(ipl(ivx,ip),29))
- * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip),
- * nacc(ivx,ip),ig,ipl(ivx,ip),.false.,
- * .false.,0,0,0,0,0,0,0.,ulq)
-c
-c Update running time
-c
- tnow = tnow+space(ib)
-10 continue
-c
-c Have finished last note in this voice and block
-c
- itendb = nint(to(istop(ib))+space(ib))
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- ivf = 1
- if (ivx .gt. 1) ivf = 2
-17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then
-c
-c There's at least one figure left. offnsk could be <0
-c
- offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib)
- call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout)
- go to 17
- end if
- end if
-c
-c Check for flag, dot, or upstem on last note of bar.
-c
- if (ib .eq. nb) then
- ip = ipo(ipl2(ivx,nn(ivx)))
- flgndv(ivx) = 0.
- if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then
- if (space(ib) .lt. 16.-tol) then
-c
-c Note in last space, smaller than a quarter note.
-c
- if ((.not.btest(irest(ivx,ip),0) .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u')
- * .or. isdotted(nodur,ivx,ip)) then
-c
-c Upstem non-rest, or dotted
-c
- if (numbms(ivx).gt.0
- * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx)))
- * .and. .not.isdotted(nodur,ivx,ip))
- * then
-c
-c In beam and not dotted, so use smaller space
-c
- flgndv(ivx) = upstmfac
- else
- flgndv(ivx) = flagfac
- end if
- end if
- else
-c
-c Last space, nonflagged (no beam) only worry dot or up
-c
- if (isdotted(nodur,ivx,ip)) then
- flgndv(ivx) = flagfac
- else if (tnote(ipl2(ivx,ip)).lt.64 .and.
- * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
- * nvmx(iv),ivx,nv).eq.'u') then
-c
-c Upstem on last note , non-flagged
-c
- flgndv(ivx) = upstmfac
- end if
- end if
- end if
-c
-c Check for right-shifted chordal note
-c
- if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac
- flgndb = flgndb .or. flgndv(ivx).gt.0.
- if (ismidi) then
-c
-c For midi, set flags for accidentals on last note of bar. Assume they affect
-c first note of next bar whether or not tied.
-c Note has already been done, so next entry into addmidi is 1st in new bar.
-c First do main note, then chord notes
-c
-c Gyrations needed to account for multi-bar tied full-bar notes?
-cc Old old lbacc(icm) = iand(nacc(ivx,ip),7)
-c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7)
-c
- if (iand(nacc(ivx,ip),7) .gt. 0) then
-c
-c Explicit accidental on last main note in bar
-c
- do 55 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56
-55 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolev(ivx,ip)
- jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7))
- end if
-56 continue
- if (btest(ipl(ivx,ip),10) .and. crdacc) then
- do 57 icrd = icrd1 , icrd2
- iacc = igetbits(icrdat(icrd),3,20)
- if (iacc .gt. 0) then
-c
-c Explicit accidental on chord note at end of bar
-c
- nolevc = igetbits(icrdat(icrd),7,12)
- do 58 kacc = 1 , naccbl(icm)
- if (laccbl(icm,kacc) .eq. nolevc) go to 59
-58 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = nolevc
- jaccbl(icm,naccbl(icm)) = iashft(iacc)
- end if
-59 continue
-57 continue
- end if
-c if (lbacc(icm).eq.0 .and. accb4(icm)) then
- do 65 kacc = 1 , naccim(icm)
-c
-c If naccim(icm)>0,
-c possible implicit accidental from earlier in the bar. Check for prior accid
-c in this bar at relevant note levels, main and chord notes. Only act if no
-c explicit action from just above. Assuming any accid on last note in bar,
-c either explicit or implicit, has same effect on 1st note of next bar.
-c
- if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66
- if (btest(ipl(ivx,ip),10)) then
- do 67 icrd = icrd1 , icrd2
- if (iand(ishft(icrdat(icrd),-12),127) .eq.
- * laccim(icm,kacc)) go to 66
-67 continue
- end if
- go to 65
-66 continue
-c
-c So far we know there is a main or chord note at level laccim(icm,kacc). So
-c it will get a bl-accid if it didn't just already get one.
-c
- do 68 macc = 1 , naccbl(icm)
- if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65
-68 continue
- naccbl(icm) = naccbl(icm)+1
- laccbl(icm,naccbl(icm)) = laccim(icm,kacc)
- jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc)
-65 continue
- end if
- end if
-11 continue
-c
-c Close out the notes group
-c
- call addstr(sq//'en',3,soutq,lsout)
- if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
-16 continue
-c
-c Check for way-after graces at end of bar. We could not link these to notes
-c as in midbar since there is no note following grace! Also, set flag if
-c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop.
-c
- isgrace = .false.
- do 75 iv = 1 , nv
- nvmxsav(iv) = nvmx(iv)
- do 75 kv = 1 , nvmx(iv)
- ivmxsav(iv,kv) = ivmx(iv,kv)
- ivx = ivmx(iv,kv)
- ptsgnd = 0.
- if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31))
- * .and. ptsndg(ivx).gt.0.) then
- flgndb = .true.
- if (ptsndg(ivx) .gt. ptsgnd) then
- ptsgnd = ptsndg(ivx)
- eskgnd = eskndg(ivx)
- end if
- end if
- if (btest(ipl(ivx,nn(ivx)),31)) then
-c
-c This voice has a way-after grace here at end of bar
-c
- if (.not.isgrace) then
-c
-c This is the first one, so set up the string
-c
- isgrace = .true.
- ivlast = 1
- soutq = sq//'znotes'
- lsout = 7
- end if
- do 76 iiv = ivlast , iv-1
- call addstr(sepsymq(iiv),1,soutq,lsout)
-76 continue
- ivlast = iv
-c
-c No need to put in 'nextvoice', even if 2 lines/staff
-c
- call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)),
- * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true.,
- * .false.,0,0,0,0,0,0,0.,ulq)
- end if
-75 continue
- if (isgrace) then
- call addstr(sq//'en%',4,soutq,lsout)
- if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout)
- end if
- lsout = 0
-c
-c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest
-c This has to be the only use of atnextbar
-c
-c if (ibar .eq. ibarmbr) then
- if (ibar.eq.ibarmbr .and. islast) then
-c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq//
-c * 'mbrest{',30,soutq,lsout)
-c ndig = int(alog10(mbrest+.01))+1
-c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest
-c lsout = lsout+ndig
-c call addstr('}{',2,soutq,lsout)
-c mtrspc = .5+xb4mbr
-c xb4mbr = 0.
-c if (mtrspc .eq. 0) then
-c ndig = 1
-c else
-c ndig = int(alog10(mtrspc+.01))+1
-c end if
-c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc
-c lsout = lsout+ndig
-c call addstr('}0'//sq//'en}%',7,soutq,lsout)
-c if (islast) write(11,'(a)')soutq(1:lsout)
-c lsout = 0
-c ndig = int(alog10(mbrest-1+.01))+1
-c if (mbrest.eq.1) ndig=1
-c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)')
-c * sq//'advance'//sq//'barno',mbrest-1,'%'
-c++
- soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes'
- lsout = 22
- notexq = sq//'mbrest'
- lnote = 7
- call istring(mbrest,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)
- lnote = lnote+len
- mtrspc = .5+xb4mbr
- xb4mbr = 0.
- call istring(mtrspc,noteq,len)
- notexq = notexq(1:lnote)//noteq(1:len)//'0'
- lnote = lnote+len+1
- do 62 iv = 1 , nv
- call addstr(notexq,lnote,soutq,lsout)
- if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-62 continue
- call addstr(sq//'en}%',5,soutq,lsout)
- write(11,'(a)')soutq(1:lsout)
- lsout = 0
- if (mbrest .gt. 1) then
- ndig = int(alog10(mbrest-1+.01))+1
- write(11,'(a14,i'//chax(48+ndig)//',a1)')
- * sq//'advance'//sq//'barno',mbrest-1,'%'
- end if
- else if (iscwr) then
-c
-c Centered whole-bar rests
-c
- call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22,
- * soutq,lsout)
- do 60 iv = 1 , nv
- lnote = 0
- do 61 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (cwrest(ivx)) then
- if (lnote .eq. 0) then
- notexq = sq//'centerbar{'
- lnote = 11
- end if
- if (.not.cwrferm(ivx)) then
- if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then
-c
-c Kluge to use new definitions for centered, stacked rests
-c
- if (cwrq(ivx)(2:10).eq.'liftpause' .or.
- * cwrq(ivx)(2:10).eq.'liftPAuse')
- * cwrq(ivx)(10:10) = 'c'
- end if
- notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx))
- lnote = lnote+lcwr(ivx)
- else
-c
-c Fermata on centered rest. Will need to fix up level.
-c 12/6/07 shift it left so it's centered over rest
-c
-c notexq = notexq(1:lnote)
-c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx))
-c lnote = lnote+11+lcwr(ivx)
-c
- notexq = notexq(1:lnote)//sq//'loffset{.39}{'
- * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx))
- lnote = lnote+26+lcwr(ivx)
- cwrferm(ivx) = .false.
- end if
- end if
-61 continue
- if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1,
- * soutq,lsout)
- if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout)
-60 continue
- call addstr(sq//'en}',4,soutq,lsout)
- if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
- end if
-c
-c End of block for centered whole-bar rests and multi-bar rests
-c
-c If at end of block, save durations of last notes in bar, for possible use
-c if clef changes at start of next bar
-c
- if (ibar .eq. nbars) then
- do 63 iv = 1 , nv
- do 63 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
-c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255))
- prevtn(ivx) = tnote(ipl2(ivx,nn(ivx)))
-63 continue
- end if
-c
-c Update time for midi. This is only used for the event track
-c
- if (ismidi) then
- miditime = miditime+15*lenbar
-c
-c If pickup, write the real time signature to the event track. Cannot use
-c mtrnuml since it was reset to 0, have to recompute it
-c
- if (lenb0 .eq. lenbar)
- * call midievent('m',mtrdenl*lenb1/64,mtrdenl)
- end if
- return
- end
- subroutine makeabar()
-c
-c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for
-c xtups, since only last note of xtup gets non-zero nodur, which
-c corresponds to single note of full length of xtup.
-c In this subroutine we make an ordered list of all notes in all voices.
-c ilnc = list note counter
-c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note.
-c to(ilnc) = real start time of note in PMX-units (64=whole note)
-c tno(ilnc) = time to next event in the bar.
-c tnote(ilnc) = actual duration of note
-c Then run thru list, grouping consecutive notes into \notes groups ib.
-c space(ib) = real time unit for the \notes group
-c squez(ib) = factor on space to get effective space. This will be 1 if
-c there is a note exactly spanning each interval of space, and
-c <1 if not.
-c Details: let eon = elemskips per noteskip (like length). Basic formula is
-c eon = sqrt(space/2.)
-c If tgovern >= space, then
-c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern).
-c Time needed to give this eon using basic formula is
-c teq = space**2/tgovern
-c Factor on space to get teq is
-c squez(ib) = space/tgovern
-c The eon for each ib can then be computed based on time of space*squez.
-c Iff squez = 1, there is a note spanning every increment in the \notes group.
-c
-c tnminb = minimum time span in the bar for increments spanned by notes,
-c i.e., with squez=1. Use after parsing into line to decide if
-c spacing needs to be "flattened" among notes groups.
-c
- common /comtol/ tol
- parameter (nm=24,nkb=3999,maxblks=4000)
- common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm),
- * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
- * nbars,itsofar(nm),nib(nm,15),nn(nm),
- * rest(nm,200),lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- logical rest,firstline,newmeter,gotclef
- integer cnn(nm),istart(80),istop(80)
- real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600)
- elskb = 0.
- tnminb(ibarcnt) = 1000.
- do 1 iv = 1 , nv
- do 1 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (ibar .gt. 1) then
- nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
- else
- nn(ivx) = nib(ivx,ibar)
- end if
-1 continue
-c
-c initialize list note counter, time(iv), curr. note(iv)
-c
- ilnc = 1
- do 4 iv = 1 , nv
- do 4 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- cnn(ivx) = 1
- ivxo(ilnc) = ivx
- ipo(ilnc) = 1
- to(ilnc) = 0.
- tnote(ilnc) = fnote(nodur,ivx,1,nacc)
- xit(ivx) = tnote(ilnc)
- if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000.
- ilnc = ilnc+1
-4 continue
-c
-c Build the list
-c
-5 continue
-c
-c Determine which voice comes next from end of notes done so far.
-c tmin is the earliest ending time of notes done so far
-c
- tmin = 1000.
- do 6 iv = 1 , nv
- do 6 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- tminn = min(tmin,xit(ivx))
- if(tminn .lt. tmin) then
- tmin = tminn
- ivnext = ivx
- end if
-6 continue
- if (tmin .gt. 999.) go to 7
- ivxo(ilnc) = ivnext
- cnn(ivnext) = cnn(ivnext)+1
- ipo(ilnc) = cnn(ivnext)
- to(ilnc) = tmin
-c
-c Check if this voice is done
-c
- tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc)
- if (cnn(ivnext) .eq. nn(ivnext)) then
- xit(ivnext) = 1000.
- else
- xit(ivnext) = xit(ivnext)+tnote(ilnc)
- end if
- ilnc = ilnc+1
- go to 5
-7 continue
- ntot = ilnc-1
- if (ntot .gt. 600) then
- call printl(' ')
- call printl('Cannot have more than 600 notes per bar, stopping')
- call stop1()
- end if
- do 8 in = 1 , ntot-1
- tno(in) = to(in+1)-to(in)
-8 continue
- tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc)
- tnote(ntot) = tno(ntot)
-c
-c Debug writes
-c
-c write(*,'()')
-c write(*,'(16i5)')(ivxo(in),in=1,ntot)
-c write(*,'(16i5)')(ipo(in),in=1,ntot)
-c write(*,'(16f5.1)')(to(in),in=1,ntot)
-c write(*,'(16f5.1)')(tno(in),in=1,ntot)
-c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
-c write(*,'(16f5.1)')(tnote(in),in=1,ntot)
-c
-c Done w/ list. Initialize loop for building note blocks:
-c
- ib = 1
- istart(1) = 1
- space(1) = 0.
- in = 1
-c
-c Start the loop
-c
-9 continue
- if (in .eq. ntot) then
- if (space(ib) .lt. tol) then
- space(ib) = tno(in)
-c
-c Last gap in bar is spanned by a note, so cannot need a squeeze.
-c
- squez(ib) = 1.
- end if
- istop(ib) = ntot
-c
-c From here flow out of this if block and into block-setup
-c
- else if (space(ib) .lt. tol) then
-c
-c space hasn't been set yet, so tentatively set:
-c
- space(ib) = tno(in)
- if (space(ib) .lt. tol) then
- in=in+1
- else
-c
-c Tentative space tno(in) is non-zero. Set squez, which will be kept (since
-c it is a unique property of the particular increment starting here) :
-c
- squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- end if
- go to 9
- else if (tno(in+1) .lt. tol) then
-c
-c This is not the last note in the space, so
-c
- in = in+1
- go to 9
- else if (abs(tno(in+1)-space(ib)) .lt. tol) then
-c
-c Next increment has same space. Does it have same squez?
-c
- xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
-c
-c If it does have the same squez, loop, otherwise flow out
-c
- if (abs(xsquez-squez(ib)) .lt. tol) then
-c
-c Keep spacing the same, update tentative stop point
-c
- in = in+1
- istop(ib) = in
- go to 9
- end if
- end if
-c
-c At this point istart, istop, space, and squez are good, so close out block
-c
- tstart(ib) = to(istart(ib))
-c
-c Compute elemskips assuming no flattening to increase min space. The formula
-c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible
-c flattening in pmxb), elsperns = squez*feon(space/squez)
-c
- elsperns = f1eon(space(ib)*squez(ib))
- if (istop(ib) .eq. ntot) then
- nnsk = nint((lenbar-tstart(ib))/space(ib))
- else
- nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib))
- end if
- elskb = elskb+elsperns*nnsk
- if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then
- call catspace(space(ib),squez(ib),nnsk)
- else
-c
-c This is the first entry for this bar
-c
- nnpd(nptr(ibarcnt)) = nnsk
- durb(nptr(ibarcnt)) = space(ib)
- sqzb(nptr(ibarcnt)) = squez(ib)
- nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
- end if
-c
-c Update minimum space spanned by a note
-c
- if (abs(squez(ib)-1) .lt. tol)
- * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib))
- if (istop(ib) .eq. ntot) go to 15
-c
-c End of spatial accounting for now
-c
- ib = ib+1
- istart(ib) = istop(ib-1)+1
- in = istart(ib)
-c
-c Set tentative block space for new block
-c
- space(ib) = tno(in)
- if (space(ib).gt.tol)
- * squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
- istop(ib) = in
- go to 9
-15 continue
-c nb = ib
-c
-c Debug writes
-c
-c write(*,'(16i5)')(istart(ib),ib=1,nb)
-c write(*,'(16i5)')(istop(ib),ib=1,nb)
-c write(*,'(16f5.1)')(space(ib),ib=1,nb)
-c write(*,'(16f5.1)')(squez(ib),ib=1,nb)
-c
- return
- end
- subroutine midievent(typeq,in1,in2)
-c
-c We now store "conductor" events in mmidi(numchan,.), and count bytes
-c with imidi(numchan)
-c
- parameter (nm=24,mv=24576)
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comevent/ miditime,lasttime
- character*1 typeq
- idur = isetvarlen(miditime-lasttime,nbytes)
- imidi(numchan) = imidi(numchan)+nbytes+1
- do 1 i = 1 , nbytes
- mmidi(numchan,imidi(numchan)-i) = mod(idur,256)
- idur = ishft(idur,-8)
-1 continue
- mmidi(numchan,imidi(numchan)) = 255
- if (typeq .eq. 't') then
-c
-c Tempo event. in1 = quarters per minute (integer)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+1
- mmidi(numchan,imidi(numchan)+2) = 3
- misperq = nint(60000000./in1)
- do 2 i = 1 , 3
- mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256)
- misperq = ishft(misperq,-8)
-2 continue
- imidi(numchan) = imidi(numchan)+5
- else if (typeq .eq. 'm') then
-c
-c Meter event. in1=numerator, in2=denom (power of 2)
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+8
- mmidi(numchan,imidi(numchan)+2) = 4
- mmidi(numchan,imidi(numchan)+3) = in1
- if (in2 .gt. 0) then
- mmidi(numchan,imidi(numchan)+4) = log2(in2)
- else
- mmidi(numchan,imidi(numchan)+4) = 0
- end if
- mmidi(numchan,imidi(numchan)+5) = 24
- mmidi(numchan,imidi(numchan)+6) = 8
- imidi(numchan) = imidi(numchan)+6
- else if (typeq .eq. 'k') then
-c
-c Keychange event. in1 = isig
-c
- mmidi(numchan,imidi(numchan)+1) = 5*16+9
- mmidi(numchan,imidi(numchan)+2) = 2
- mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256)
- mmidi(numchan,imidi(numchan)+4) = 0
- imidi(numchan) = imidi(numchan)+4
- else
- print*,'Program flameout in midievent'
- call stop1()
- end if
- lasttime = miditime
- return
- end
- subroutine moveln(iuin,iuout,done)
- logical done
- character*129 outq
- done = .false.
- read(iuin,'(a)',end=1) outq
- lenout = llen(outq,129)
- write(iuout,'(a)') outq(1:lenout)
- return
-1 done = .true.
- return
- end
- subroutine mrec1(lineq,iccount,ndxm)
-c
-c This is called when (a) macro recording is just starting and
-c (b) at the start of a new line, if recording is on
-c
- parameter (maxblks=4000)
- character*128 lineq,lnholdq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- if (.not.mrecord) then
-c
-c Starting the macro
-c
- ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
- il1mac(macnum) = ilbuf-1
- ic1mac(macnum) = iccount
- mrecord = .true.
- end if
- if (iccount .lt. 128) then
- ndxm = index(lineq(iccount+1:128),'M')
- if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
- * 128-iccount)
- if (ndxm .gt. 0) then
-c
-c This line ends the macro.
-c
- ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
- il2mac(macnum) = ilbuf-1
- mrecord = .false.
- end if
- end if
- return
- end
- function ncmid(iv,ip)
- parameter (nm=24)
- common /all/ mult(nm,200),jv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- if (ncc(iv) .eq. 1) then
- ncmid = ncmidcc(iv,1)
- else
- xtime = to(ipl2(ivx,ip))
- do 1 icc = ncc(iv) , 1 , -1
- if (xtime .gt. tcc(iv,icc)-tol) then
- ncmid = ncmidcc(iv,icc)
- return
- end if
-1 continue
- print*,'Problem in ncmid()'
- stop
- end if
- end
- function ncmidf(clefq)
-c
-c Return middle line of a clef
-c
- character*1 clefq
-c if (clefq.eq.'t' .or. clefq.eq.'0') then
-c ncmidf = 35
-c else if (clefq.eq.'s' .or. clefq.eq.'1') then
-c ncmidf = 33
-c else if (clefq.eq.'m' .or. clefq.eq.'2') then
-c ncmidf = 31
-c else if (clefq.eq.'a' .or. clefq.eq.'3') then
-c ncmidf = 29
-c else if (clefq.eq.'n' .or. clefq.eq.'4') then
-c ncmidf = 27
-c else if (clefq.eq.'r' .or. clefq.eq.'5') then
-c ncmidf = 25
-c else if (clefq.eq.'f' .or. clefq.eq.'7') then
-c ncmidf = 37
-c else
-c ncmidf = 23
-c end if
- ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2
- return
- end
- subroutine newvoice(jv,clefq,change)
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- character*1 ulfbq,clefq
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- logical change,autofbon
- nvmx(jv) = 1
- ivmx(jv,1) = jv
- itsofar(jv) = 0
- nnl(jv) = 0
- nfb(jv) = 0
- if (firstgulp .or. change) then
- ncmidcc(jv,1) = ncmidf(clefq)
- else
- ncmidcc(jv,1) = ncmidcc(jv,ncc(jv))
- end if
- tcc(jv,1) = 0.
- ncc(jv) = 1
- nudoff(jv) = 0
- ndotmv(jv) = 0
- do 5 j = 1 , 200
- irest(jv,j) = 0
- islur(jv,j) = 0
- ipl(jv,j) = 0
- nacc(jv,j) = 0
- iornq(jv,j) = 0
- mult(jv,j) = 0
- if (jv.le.2) isfig(jv,j) = .false.
-5 continue
- return
- end
- subroutine notefq(noteq,lnote,nolev,ncmid)
-c
-c Returns name of note level with octave transpositions, updates noctup.
-c
- common /comoct/ noctup
- character*8 noteq
- character*1 upcaseq,noteqt,chax
- nupfroma = mod(nolev+1,7)
- iname = 97+nupfroma
- ioctup = (nolev+1)/7-4
- noteqt = chax(iname)
- if (ncmid .eq. 23) noteqt = upcaseq(noteqt)
- if (ioctup .eq. noctup) then
- noteq = noteqt
- lnote = 1
-c
-c Must ALWAYS check if lnote=1 for use with functions requiring a blank
-c
- else if (ioctup .gt. noctup) then
-c
-c Raise octave. Encase in {}
-c
- write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1),
- * noteqt,'}'
- lnote = 3+ioctup-noctup
- noctup = ioctup
- else
-c
-c Lower octave
-c
- write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1),
- * noteqt,'}'
- lnote = 3+noctup-ioctup
- noctup = ioctup
- end if
- return
- end
- subroutine notex(notexq,lnote)
-c
-c Returns non-beamed full note name
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig,ispoi,btest,even
- character*1 udq,udqq,chax
- character*4 dotq
- character*2 numq
- character*79 notexq
- character*8 noteq
- character*40 restq
- common /compoi/ ispoi
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figq
- ip = ipo(jn)
- nole = nolev(ivx,ip)
-c
-c Check for special situations with 2nds (see precrd)
-c
- if (btest(nacc(ivx,ip),30)) then
- nole = nole - 1
- else if (btest(nacc(ivx,ip),31)) then
- nole = nole + 1
- end if
- nodu = nodur(ivx,ip)
- if (.not.btest(irest(ivx,ip),0)) then
- udq = udqq(nole,ncmid(iv,ip),
- * islur(ivx,ip),nvmx(iv),ivx,nv)
- end if
-c
-c Check figure level
-c
-c if (figbass .and. isfig(ivx,ip)
-c * .and. .not.btest(irest(ivx,ip),0)) then
- if (figbass .and. .not.btest(irest(ivx,ip),0) .and.
- * ((ivx.eq.1.and.isfig(1,ip))
- * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then
- if (udq .eq. 'u' .or. nodu.ge.64) then
-c
-c Upper or no stem, fnole (in noleunits) set by notehead
-c
- fnole = nole
- else
-c
-c Lower stem, fnole set by bottom of stem
-c
- fnole = nole-stemlen
- end if
- zmin = fnole-ncmid(ivx,ip)+4
- if (ivx .eq. 1) then
- ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin))
- else
- ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin))
- end if
- end if
- if (.not.btest(irest(ivx,ip),0)) then
- call notefq(noteq,lnoten,nole,ncmid(iv,ip))
- if (lnoten .eq. 1) call addblank(noteq,lnoten)
- if (nodu .eq. 1) then
- notexq =sq//'cccc'//udq//noteq(1:lnoten)
- lnote = lnoten+6
- else if (nodu .eq. 2) then
- notexq =sq//'ccc'//udq//noteq(1:lnoten)
- lnote = lnoten+5
- else if (nodu .eq. 4) then
- notexq =sq//'cc'//udq//noteq(1:lnoten)
- lnote = lnoten+4
- else if (nodu .eq. 8) then
- notexq =sq//'c'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 16) then
- notexq =sq//'q'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 32) then
- notexq =sq//'h'//udq//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 64) then
- notexq =sq//'wh'//noteq(1:lnoten)
- lnote = lnoten+3
- else if (nodu .eq. 128) then
-c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk'
-c lnote = lnoten+10
- notexq =sq//'breve'//noteq(1:lnoten)
- lnote = lnoten+6
- else
- dotq = 'p'
- ldot = 1
- if (btest(iornq(ivx,ip),13)) then
-c
-c Dotted note with ')' ornament
-c
- dotq='m'
- else if (btest(islur(ivx,ip),3)) then
-c
-c Double dot
-c
- dotq = 'pp'
- ldot = 2
- end if
- if (nodu .ge. 192) then
- notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+6+ldot
- else if (nodu .ge. 96) then
- notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 48) then
- notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 24) then
- notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 12) then
- notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+3+ldot
- else if (nodu .ge. 6) then
- notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+4+ldot
- ispoi = .true.
- else
- notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten)
- lnote = lnoten+5+ldot
- ispoi = .true.
- end if
- if (dotq(1:1) .eq. 'm') then
-c
-c Need another call to the note, in case the first one has octave shifts
-c
- if (lnoten .eq. 2) then
- notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
- lnote = lnote+3
- else
- notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
- lnote = lnote+1
- end if
- end if
- end if
- else if (btest(islur(ivx,ip),29)) then
-c
-c Blank rest
-c
- notexq = sq//'sk'
- lnote = 3
- else
-c
-c Non-blank rest
-c
- lnote = 0
- nole = mod(nole+20,100)-20
-c
-c Kluge to get pause symbol for rp:
-c
- if (btest(islur(ivx,ip),19)) nodu = 64
- if (nodu .le. 28) then
-c
-c Normal rest < or = double-dotted quarter
-c
- lrest = 3
- if (nodu .gt. 14) then
- restq =sq//'qp'
- else if (nodu .gt. 7) then
- restq =sq//'ds'
- else if (nodu .gt. 3) then
- restq =sq//'qs'
- else if (nodu .gt. 1) then
- restq =sq//'hs'
- else
- restq =sq//'qqs'
- lrest = 4
- end if
-c if (2**log2(nodu) .ne. nodu) then
-cc
-cc One or two dots on rest
-cc
-c restq = restq(1:3)//'p'
-c lrest = 4
-c if (2*nodu .gt. 3*2**log2(nodu)) then
-cc
-cc Double dotted rest
-cc
-c restq = restq(1:4)//'p'
-c lrest = 5
-c end if
-c end if
- notexq = restq
- lnote = lrest
-c
-c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc.
-c
- if (nole .ne. 0) then
- if (abs(nole) .lt. 10) then
- noteq = chax(48+abs(nole))
- lnoten = 1
- else
- write(noteq(1:2),'(i2)')abs(nole)
- lnoten = 2
- end if
- if (nole .gt. 0) then
- notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
- else
- notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
- end if
- lnote = 16+lnoten
-c if (2**log2(nodu) .ne. nodu) then
-cc
-cc Have dot in raised rest. must put in hbox!
-cc
-c notexq = notexq(1:lnote)//sq//'hbox{'
-c lnote = lnote+6
-c end if
- notexq = notexq(1:lnote)//restq(1:lrest)
- lnote = lnote+lrest
-c if (2**log2(nodu) .ne. nodu) then
-c notexq = notexq(1:lnote)//'}'
-c lnote = lnote+1
-c end if
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Deal with dots (on rests shorter than half rest)
-c
- restq = sq//'pt'
- lrest = 3
- if (2*nodu .gt. 3*2**log2(nodu)) then
- restq = sq//'ppt'
- lrest = 4
- end if
- nole = nole+4
- raisedot = 0
-c
-c Tweak dot positions for special cases
-c
- even = (mod(100+nole,2).eq.0)
-c if (.not.even.and.nodu.gt.8.and.
-c * (nole.lt.0.or.nole.gt.8)) then
- if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then
- raisedot = 1
- end if
- if (nole.ge.10 .or. nole.le.-1) then
- write(numq,'(i2)')nole
- restq = restq(1:lrest)//'{'//numq//'}'
- lrest = lrest+4
- else
- restq = restq(1:lrest)//chax(nole+48)
- lrest = lrest+1
- end if
- if (raisedot.gt.0) then
- restq = sq//'raise'//sq//'internote'//
- * sq//'hbox{'//restq(1:lrest)//'}'
- lrest = lrest+23
- end if
-
-
-
- notexq = restq(1:lrest)//notexq(1:lnote)
- lnote = lnote+lrest
- end if
- else
-c
-c Half rest or longer
-c
- if (nole .eq. 0) then
-c
-c Half or longer rest is not raised or lowered
-c
- if (nodu .le. 56) then
- notexq =sq//'hpause'
- lnote = 7
- else if (nodu .le. 112) then
- if (.not.btest(islur(ivx,ip),19) .or.
- * btest(irest(ivx,ip),25)) then
- notexq = sq//'pause'
- else
- notexq = sq//'pausc'
- end if
- lnote = 6
- else
- notexq =sq//'PAuse'
- lnote = 6
- end if
- if (2**log2(nodu) .ne. nodu) then
-c
-c Dotted rest, hpause or longer
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- if (2*nodu .gt. 3*2**log2(nodu)) then
-c
-c Double dotted long rest
-c
- notexq = notexq(1:lnote)//'p'
- lnote = lnote+1
- end if
- end if
- else
-c
-c Raised or lowered half or whole rest
-c
- if (nodu .eq. 32) then
- notexq = sq//'lifthpause'
- lnote = 11
- else if (nodu .eq. 48) then
- notexq = sq//'lifthpausep'
- lnote = 12
- else if (nodu .eq. 56) then
- notexq = sq//'lifthpausepp'
- lnote = 13
- else if (nodu .eq. 64) then
- notexq = sq//'liftpause'
- lnote = 10
- else if (nodu .eq. 96) then
- notexq = sq//'liftpausep'
- lnote = 11
- else if (nodu .eq. 112) then
- notexq = sq//'liftpausepp'
- lnote = 12
- else if (nodu .eq. 128) then
- notexq = sq//'liftPAuse'
- lnote = 10
- else
-c
-c Assume dotted double whole rest
-c
- notexq = sq//'liftPAusep'
- lnote = 11
- end if
-c
-c Set up height spec
-c
- nole = sign(abs(nole)/2,nole)
- if (nole.le.9 .and. nole.ge.0) then
- noteq = chax(48+nole)
- lnoten = 1
- else
- noteq = '{'
- if (nole .ge. -9) then
- write(noteq(2:3),'(i2)')nole
- lnoten = 3
- else
- write(noteq(2:4),'(i3)')nole
- lnoten = 4
- end if
- noteq = noteq(1:lnoten)//'}'
- lnoten = lnoten+1
- end if
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- end if
- end if
- return
- end
- function ntindex(line,s2q,lenline)
-c
-c Returns index(line,s2q) if NOT in TeX string, 0 otherwise
-c
- character*(*) s2q,line
- character*1 chax
- logical intex
- ndxs2 = index(line,s2q)
- ndxbs = index(line,chax(92))
- if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
- ntindex = ndxs2
- else
-c
-c There are both bs and s2q, and bs is to the left of sq2. So check bs's to
-c right of first: End is '\ ', start is ' \'
-c
- len = lenstr(line,lenline)
- intex = .true.
- do 1 ic = ndxbs+1 , len
- if (ic .eq. ndxs2) then
- if (intex) then
- ntindex = 0
- ndxs2 = index(line(ic+1:len),s2q)+ic
- else
- ntindex = ndxs2
- return
- end if
- else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then
- intex = .false.
- else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92))
- * then
- intex = .true.
- end if
-1 continue
- end if
- return
- end
- subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote)
-c
-c This appends to notexq e.g. '\ibbbu1'
-c
- common /combbm/ isbbm
- logical isbbm
- character*79 notexq
- character*1 char1q,ulqq,chax
- character*4 tempq
- if (n .ge. 5) isbbm = .true.
- if (lnote .gt. 0) then
- notexq = notexq(1:lnote)//chax(92)//char1q
- else
- notexq = chax(92)//char1q
- end if
- lnote = lnote+2
- do 3 im = 1 , n
- notexq = notexq(1:lnote)//'b'
- lnote = lnote+1
-3 continue
-c
-c add the number, 0 if 12
-c
-c 5/25/08 Allow >12
-c
-c call istring(mod(iv,12),tempq,len)
- if (iv .lt. 24) then
- call istring(iv,tempq,len)
- else if (iv .eq. 24) then
- tempq(1:1) = '0'
- len = 1
- else
- call printl('Sorry, too man open beams')
- call stop1()
- end if
- notexq = notexq(1:lnote)//ulqq//tempq(1:len)
- lnote = lnote+1+len
- return
- end
- function numclef(clefq)
-c
-c Returns the number to be used as argument of \setclef (for MusiXTeX only)
- character*1 clefq
-c if (ichar(clefq) .lt. 55) then
- if (ichar(clefq) .le. 55) then
- numclef = ichar(clefq)-48
- if (numclef .eq. 7) numclef = 9
- else
- numclef = index('tsmanrbxxf',clefq)-1
- end if
- return
- end
- subroutine outbar(i,jlast)
- character*1 chax
- nfmt = log10(i+.5)+2
- if (jlast+5+nfmt .lt. 80) then
- write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = jlast+5+nfmt
- else
- write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i
- jlast = 5+nfmt
- end if
- return
- end
- subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize)
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc cc
-cc Subroutine, combine with pmxb.for
-cc
-cccccccccccccccccccccccccccccccccccccccccccccccc
-cc
-cc Need to consider X spaces in xtuplets when getting poenom, and
-cc maybe fbar?
-cc mx06a
-cc ID numbers for voices when number of voices is reduced.
-cc
-cc mx03a
-cc account for new fracindent for new movements.
-cc
-cc Known changes since pmxa. Version 1.1b (see pmxb for longer list)
-cc
-cc Check ID codes for slurs.
-cc Version 1.24 still does not have details for spacing/positioning
-cc arpeggios if there are accidentals or shifted notes or crowded scores.
-cc Fix problem in 1.22 with arpeggios across multi-line staves
-cc Fix problem in 1.22 with flat key signatures
-cc Read setup data as strings
-cc Warning for octave designation plus +/-
-cc Don't pause for volta warning,
-cc Macros
-cc Correct fsyst to account for transposition and key changes.
-cc Check for nbars > nsyst
-cc
-ccccccccccccccccccccccccccccccccccc
- parameter (nm=24,nkb=3999,nks=125,maxblks=4000)
- logical loop,usefig,isfirst,optimize
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- integer nn(nm),nodur(nm,200),ivxo(600),ipo(600),
- * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks)
- common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks),
- * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr,
- * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks)
- common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
- * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
- * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30),
- * nistaff(0:40)
- common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
- * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS
- real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600)
- character*128 lnholdq
- character*44 basenameq
- logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt,
- * stickyS
- common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
- * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0
- logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr,
- * shifton,barend
- common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml,
- * nodur,lenbar,iccount,nbars,itsofar,nib,nn,
- * rest,lenbr0,lenbr1,firstline,newmeter
- common /linecom/ elskb,tnminb(nkb)
- common /cblock/
- * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
- * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
- common /cominbot/ inbothd
- common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200)
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /commus/ musize,whead20
- common /comeon/ eonk,ewmxk
- logical mrecord,mplay,endmac,gotclef,cstuplet
- logical novshrinktop,upslur,fontslur,WrotePsslurDefaults
- common /comnvst/ novshrinktop,cstuplte
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- logical fulltrans
- data wtimesig,wclef,wkeysig
- * / 0.72 , 0.8 , 0.28 /
- whead20 = 0.3
- if (.not.optimize) then
- print*
- print*,'Starting first PMX pass'
- write(15,'(a)') ' Starting first PMX pass'
- end if
- if (isfirst) then
- open(19,file='pmxaerr.dat')
- write(19,'(i6)') 0
- close(19)
- end if
- if (.not.optimize) jprntb = 81
- macuse = 0
- ornrpt = .false.
- stickyS = .false.
- mrecord = .false.
- mplay = .false.
- lastchar = .false.
- novshrinktop = .false.
- cstuplet = .false.
- fontslur = .true.
- isligfont = .false.
- fulltrans = .false.
- do 42 ibarcnt = 1 , nkb
- udsp(ibarcnt) = 0.
- wminnh(ibarcnt) = -1.
-42 continue
-c
-c Initialize input buffer
-c
- lenbuf0 = ipbuf
- ipbuf = 0
- ilbuf = 1
- call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
- * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb)
-c
-c Set up list of instrument numbers (iv)
-c
- ivnow = 0
- do 13 instnow = 1 , noinst
- do 14 iscount = 1 , nsperi(instnow)
- ivnow = ivnow+1
- instno(ivnow) = instnow
-14 continue
-13 continue
-c
-c Save initial meter for midi
-c
- if (.not.isfirst .and. npages.eq.0) then
- print*,'Sorry, must have npages>0 for optimization.'
- call stop1()
- end if
- nsyout = nsyst
-c
-c isig1 will be changed in getnote if there is a transposition
-c
- isig1 = newkey(1)
- if (npages .gt. nsyst) then
- call printl('npages > nsyst in input. Please fix the input.')
- call stop1()
- end if
-c
-c fbar = afterruleskip/elemskip
-c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt
-c
- fbar = 1.
- wheadpt = whead20*musize
- ifig = 0
- usefig = .true.
- lenbeat = i1fnodur(mtrdenl,'x')
- lenmult = 1
- if (mtrdenl .eq. 2) then
- lenbeat = 16
- lenmult = 2
- end if
- lenbr1 = lenmult*mtrnuml*lenbeat
- lenbr0 = nint(lenmult*xmtrnum0*lenbeat)
- mtrnuml = 0
- if (lenbr0 .ne. 0) then
- ibaroff = 1
- lenbar = lenbr0
- else
- ibaroff = 0
- lenbar = lenbr1
- end if
- ibarcnt = 0
- nptr(1) = 1
- iccount = 128
- nmovbrk = 0
- nflb = 0
- nfpb = 0
- ipagfpb(0) = 1
- isysfpb(0) = 1
- ibarflb(0) = 1
- isysflb(0) = 1
- nistaff(0) = nv-1
-c
-c Check for pmx.mod
-c
- linesinpmxmod = 0
-c line1pmxmod = ilbuf
- call getpmxmod(.true.,' ')
- if (.not.isfirst .and. linesinpmxmod .gt. 0) then
- print*,'Sorry, cannot optimize if there is a pmx.mod file'
- call stop1()
- end if
-c
-c Initialize for loop over lines
-c
- nkeys = 1
- ibrkch(1) = 1
- mbrestsav = 0
- shifton = .false.
- firstline = .true.
- newmeter = .false.
- ihead = 0
- isheadr = .false.
- gotclef = .false.
- idsig = 0
- iddot = 0
- fintstf = -1.
- gintstf = 1.0
- listcresc = 0
- listdecresc = 0
-30 loop = .true.
- iskchb = .false.
- issegno = .false.
- nbars = 0
- ibarmbr = 0
-3 do 4 iv = 1 , nv
- nvmx(iv) = 1
- ivmx(iv,1) = iv
- itsofar(iv) = 0
- nnl(iv) = 0
- do 5 j = 1 , 200
- rest(iv,j) = .false.
- nacc(iv,j) = 0.
-5 continue
-4 continue
- iv = 1
- ivx = 1
- fbon = .false.
- barend = .false.
- isvolt = .false.
-2 if (loop) then
-c
-c Within this short loop, nv voices are filled up for the duration of a block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nodur(..),rest(..). nnl will later be
-c increased and things slid around as accidental skips are added.
-c
- call g1etnote(loop,ifig,optimize,fulltrans)
- if (lastchar) go to 20
- go to 2
- end if
- if (mbrestsav .gt. 0) then
- call printl(' ')
- call printl(
- * 'You must enter the same multibar rest in ALL parts')
- call stop1()
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
-c
-c The following is just a signal to start a new bar when cataloging spaces
-c for catspace(...)
-c
- nptr(ibarcnt+1) = nptr(ibarcnt)
- newmb(ibarcnt) = .false.
- if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true.
-c
-c Above is only for spacing calcs later on. Remember new meter can only occur
-c at START of a new input line (ibar = 1)
-c
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb)
- else
- if (.not.optimize) then
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
- jprntb = 0
- end if
- ibaroff = ibaroff-mbrest+1
- end if
- if (firstline .and. lenbr0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenbr0
- else
- lenbar = lenbr1
- end if
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- rest(ivx,ip) = rest(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
-12 continue
-11 continue
- end if
- do 67 iv = 1 , nv
- do 67 kv = 1 , nvmx(iv)
- ioff= 0
- if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1)
-67 continue
- call makeabar()
- elsk(ibarcnt) = elskb+fbar
-10 continue
- newmeter = .false.
- firstline = .false.
- go to 30
-20 continue
-c
-c Vertical analysis.
-c
- if (npages .eq. 0) then
- if (nsyst .eq. 0) then
- print*,'When npages=0, must set nsyst=bars/syst, not 0'
- call stop1()
- end if
- nsyst = (ibarcnt-1)/nsyst+1
- if (nv .eq. 1) then
- nsystpp = 12
- else if (nv .eq. 2) then
- nsystpp = 7
- else if (nv .eq. 3) then
- nsystpp = 5
- else if (nv .eq. 4) then
- nsystpp = 3
- else if (nv .le. 7) then
- nsystpp = 2
- else
- nsystpp = 1
- end if
- npages = (nsyst-1)/nsystpp+1
- end if
-c
-c Check nsyst vs ibarcnt
-c
- if (nsyst .gt. ibarcnt) then
- print*
- print*,'nsyst,ibarcnt:',nsyst,ibarcnt
- print*,'There are more systems than bars.'
- write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt
- write(15,'(a)')' There are more systems than bars.'
- call stop1()
- end if
-c
-c Set up dummy forced line & page breaks after last real one
-c
- nflb = nflb+1
- ibarflb(nflb) = ibarcnt+1
- isysflb(nflb) = nsyst+1
- nfpb = nfpb+1
- ipagfpb(nfpb) = npages+1
- isysfpb(nfpb) = nsyst+1
- heightil = ptheight*4./musize
- open(12,status='SCRATCH')
- write(12,'(a)')basenameq(1:lbase)
- write(12,*)lbase
-c
-c Pass to pmxb the initial signature, including effect of transposition.
-c
- write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait,
- * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1
- write(12,*)npages,widthpt,ptheight,nsyst
- iflbnow = -1
- isysb4 = 0
- do 8 ifpb = 1 , nfpb
-c
-c Each time thru this loop is like a single score with several pages
-c
- npages = ipagfpb(ifpb)-ipagfpb(ifpb-1)
- nsyst = isysfpb(ifpb)-isysfpb(ifpb-1)
- nomnsystp = (nsyst-1)/npages+1
- nshort = nomnsystp*npages-nsyst
- do 7 ipage = 1 , npages
- nsystp = nomnsystp
- if (ipage .le. nshort) nsystp = nsystp-1
-c
-c Last system number on this page:
- isysendpg = isysb4+nsystp
- nintpg = 0
- do 15 isy = isysb4+1, isysendpg
- if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1
- nintpg = nintpg+nistaff(iflbnow)
-15 continue
- xilfrac = 0.
- xiltxt = 0.
- if (ipage.eq.1 .and. ihead.gt.0) then
-c
-c Needn't zero out ihead after printing titles if we only allow titles at top?
-c
- if (iand(ihead,1) .eq. 1) then
- xiltxt = xiltxt+hgtin*4/musize
- xilfrac = xilfrac+etait
- end if
- if (iand(ihead,2) .eq. 2) then
- xiltxt = xiltxt+hgtti*4/musize
- xilfrac = xilfrac+etatc
- end if
- if (iand(ihead,4) .eq. 4) then
- xiltxt = xiltxt+hgtco*4/musize
- xilfrac = xilfrac+etacs1
- else
-c
-c Use double the title-composer space if there is no composer
-c
- xilfrac = xilfrac+etatc
- end if
- end if
- D = xilfrac+nsystp-1+etatop+etabot
-c C = nsystp*(nv-1)
- C = nintpg
-c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn
- xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn
- if (bottreb) xN = xN-(nsystp-1)*xilbtc
- if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr
- if (ifig .eq. 1) then
- xN = xN - nsystp*xilfig
- end if
- glueil = (xN-b*C)/(D+a*C)
- omegaG = (b*D+a*xN)/(D+a*C)
-c
-c G = \interlines between systems
-c omega*G = \interlines between staves of the same system
-c \interstaff = 4+omega*G
-c C = total number of interstaff spaces in the page
-c D = omega-indep factors for scalable height = nsy-1 (intersystem glue)
-c + etatop + etabot + etatxt +
-c N = scaleable height (\interlignes) = height - htext - staff heights - xil
-c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles
-c + (nsy-1)*xiltcb for treble clef bottoms
-c + nsy*xilfig for figures
-c G = N/(D + omega * C) = glueil, (1)
-c But (empirically) omega*G = a*G + b (2)
-c with a=1.071 and b=2.714
-c Solving (1) and (2) gives
-c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C)
-c Pass to pmxb omega*G (=\interstaff-4)
-c (etatop,bot,it,tc,cx)*G as inputs to \titles
-c
-c glueil = (heightil-xiltxt-nsystp*(xil+4*nv))
-c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac)
-c xnsttop = glueil*etatop
-c xintstaff = 4+gfact*glueil
-c
-c Only the first page will get local adjustment now if needed, others in pmxb
-c
- if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then
- facins = fintstf
- fintstf = -1.
- else
-c
-c gintstf = 1.0 by default, but may be changed with AI<x>
-c
- facins = gintstf
- end if
- write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4)
- ihead = 0
- isheadr = .false.
- isysb4 = isysendpg
-7 continue
-8 continue
-c
-c Done with vertical, now do horizontals
-c
- celsk(1) = elsk(1)
- do 21 ibar = 2 , ibarcnt
- celsk(ibar) = celsk(ibar-1)+elsk(ibar)
-21 continue
- lastbar(0) = 0
- ibar1 = 1
- wmins = -1.
- iflb = 1
- imovbrk = 0
- ikey = 1
-c
-c Return nsyst to its *total* value
-c
- nsyst = isysfpb(nfpb)-1
- do 22 isyst = 1 , nsyst
- if (isyst .eq. isysflb(iflb)) iflb = iflb+1
- if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then
- if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1
- end if
- ibarb4 = lastbar(isyst-1)
- if (isyst .eq. 1) then
- if (isfirst) elsstarg = celsk(ibarflb(1)-1)/
- * (isysflb(1)-1-fracindent)*(1-fracindent)
- celskb4 = 0.
- else
- celskb4 = celsk(ibarb4)
-c
-c Must dimension isysmb(0:*) just so I can execute this test!
-c
- if (isfirst) then
- if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then
-c
-c First syst after forced line break. There may be indentation.
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst-fracsys(imovbrk))
- * *(1-fracsys(imovbrk))
- else
-c
-c There is no indentation to deal with
-c
- elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
- * /(isysflb(iflb)-isyst)
- end if
- end if
- end if
- if (isfirst) then
- diff1 = abs(elsstarg-elsk(ibarb4+1))
- do 23 ibar = ibarb4+2 , ibarcnt
- diff = elsstarg-(celsk(ibar)-celskb4)
- if (abs(diff) .ge. diff1) go to 24
- diff1 = abs(diff)
-23 continue
-24 ibar = ibar-1
- lastbar(isyst) = ibar
- nbarss(isyst) = ibar-ibarb4
- else
-c
-c nbarss is given as an input, must compute lastbar and ibar
-c
- lastbar(isyst) = nbarss(isyst)+ibarb4
- ibar = lastbar(isyst)
- end if
-c
-c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's.
-c
- elss(isyst) = celsk(ibar)-celskb4
- write(12,'(i5)')lastbar(isyst-1)+1
-c
-c Transposed sigs are isig1, newkey(2,3,...).
-c
- if (ikey .eq. 1) then
- key1 = isig1
- else
- key1 = newkey(ikey)
- end if
- fsyst = wclef+abs(key1)*wkeysig+2./musize
- xelsk = 0.
-1 if (ikey.lt.nkeys) then
- if (ibrkch(ikey+1).le.lastbar(isyst)) then
-c
-c Add space for all key changes
-c
- ikey = ikey+1
- key2 = newkey(ikey)
- naccs = max(abs(key2-key1),max(abs(key1),abs(key2)))
- fsyst = fsyst+naccs*wkeysig
-c
-c Account for afterruleskips (fbar)
-c
- xelsk = xelsk+fbar/2
- if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey))
- * xelsk = xelsk-1.
- key1 = key2
- go to 1
- end if
- end if
-c
-c Add extra fixed space for double bar
-c
- if (isyst .eq. nsyst) then
- fsyst = fsyst+4.5/musize
- end if
-c
-c Add extra fixed space for initial time signature
-c
- if (isyst .eq. 1) then
- fsyst = fsyst+wtimesig
- end if
-c
-c Add extra fixed space for time signature changes & user-defined spaces
-c
- do 26 ibars = ibarb4+1 , lastbar(isyst)
- if (newmb(ibars)) fsyst = fsyst+wtimesig
- fsyst = fsyst+udsp(ibars)/musize
-26 continue
- if (isyst .eq. 1) then
- wdpt = widthpt*(1-fracindent)
- else
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- wdpt = widthpt*(1-fracsys(imovbrk))
- else
- wdpt = widthpt
- end if
- end if
- wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst)
-c
-c Checks for min spacing
-c Get min allowable space
-c
- dtmin = 1000.
- do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1
- dtmin = min(dtmin,tnminb(ibar))
- if (wminnh(ibar).ge.0.) wmins = wminnh(ibar)
-45 continue
- if (wmins .lt. 0) wmins = 0.3
- wminpt = (1+wmins)*0.3*musize
-c
-c Find max duration & # of notes for this system
-c
- dtmax = 0.
- nns = 0
- do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- dtmax = max(dtmax,durb(iptr))
- nns = nns + nnpd(iptr)
-43 continue
- elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk)
- if (elmin0 .ge. wminpt) then
-c
-c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb;
-c there is no need to "flatten"
-c
- sumelsk = elss(isyst)-fbar*nbarss(isyst)
- eonk = 0.
- ewmxk = 1.
- else
- elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns)
- if (elmin1 .le. wminpt) then
-c print*
-c print*,'In system #',isyst,' cannot meet min. space rqmt'
-c write(15,'(/a,i5,a)')
-c * 'In system #',isyst,' cannot meet min. space rqmt'
- eonk = 0.9
- else
-c
-c Find eonk by Newton method
-c
-c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0))
- call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1,
- * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax,
- * (wminpt-elmin0)/(elmin1-elmin0))
- eonk = min(.9,eonk)
- end if
- ewmxk = f1eon(dtmax)**eonk
-c
-c Recompute poenom!
-c
- sumelsk = 0
- do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
- sumelsk = sumelsk
- * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr))
-44 continue
- end if
- poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk)
-c
-c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0
-c
- if (isyst .gt. 0) then
- if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
- * isyst.eq.isysmb(imovbrk)) then
- fracindent = fracsys(imovbrk)
- else
- fracindent = 0.
- end if
- end if
- write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst),
- * sumelsk,fsyst,fracindent,eonk,ewmxk
- ibar1 = ibar1+nbarss(isyst)
-22 continue
- rewind(12)
- open(13,status='SCRATCH')
- write(13,'(i5)')ifig
- rewind(13)
- ilbuf = 1
- ipbuf = 0
- if (.not.optimize) then
- write(*,'(/,a)')' Done with first pass'
- print*
- write(15,'(/,a)')' Done with first pass'
- write(15,'()')
- end if
-c
-c Following syntax is needed since pmxa is called with literal argument .false.
-c
- if (isfirst) isfirst = .false.
- return
- end
- subroutine pmxb(inlast,poevec,ncalls,optimize)
-cccccccccccccccccccccccccc
-cc
-cc To Do
-cc
-cc Resolve disagreement in final poe for 1st system, compared with *.mx2
-cc Shift slurs on right- or left-shifted main notes (2/7/99)
-cc Various end-of-input-block repeat problems (ick142.pmx).
-cc Force multiplicity for un-beamed xtups.
-cc Clef change at end of piece
-cc Global "A" option to maximize "X" at a given time tick.
-cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted
-cc note. See trubl18.pmx
-cc Tab character as space.
-cc Clef interference with second line of music.
-cc Add space for interferences between *different* lines of music?
-cc Shift arpeggios, both automatic and manual.
-cc Different musicsize for different instruments.
-cc Spacing checks for accid's on left-shifted chord notes
-cc Spacing checks for double dots
-cc Allow forced line breaks w/o setting nsyst.
-cc Cresc-Decresc. (Enhance MusiXTeX first?)
-cc Dynamic Marks.
-cc Bug with Voltas at line end (MusiXTeX problem?).
-cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx
-cc Stem-end slurs.
-cc Allow units in indentation.
-cc Make inline TeX more context sensitive.
-cc Werner's 4/2/98 problem with "o?"
-cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong.
-cc converts e.g. "r2db" into "r2d", which might be wrong.
-cc Werner's generalsignature problem with Key change and new transposition.
-cc (wibug8.pmx)
-cc Unequal xtuplets
-cc Print both sets of bar #'s in tex file.
-cc Make barlines invisible \def\xbar{\empty} , fix fbar.
-cc Auto-tie slurs 'At'
-cc Forced line break anywhere (e.g. at a mid-bar repeat).
-cc Clef change at very start of file.
-cc Tighten test for M as macro terminator.
-cc Fix title so not separate limit on author length + composer length.
-cc Arpeggios in xtups.
-cc
-cc mx10b
-cc Option for instrument name at top center. Last item in P command:
-cc P[n]c text is instrument name (use in parts)
-cc P[n]cstuff text is stuff (up to 1st blank)
-cc P[n]c"stuff with spaces" text is stuff with spaces
-cc
-cc Post version 1.43
-cc Reduced space rqmt for multiplicity-0 graces (no flag)
-cc Removed last sepsym in centered whole-bar rests, fixes volta height bug.
-cc
-cc Version 1.43
-cc Fix spacing for end-of-line signature change.
-cc Adjust left-shift of grace group for shifted accidentals.
-cc Put in extra space for left-shifted accidentals.
-cc Fix bug with dot-shift before accid-shift on chord note.
-cc Space-check for right-shifted main notes.
-cc Enable forcing stem direction of single notes in non-beamed xtups.
-cc Disallow clef change after last note before end of input block (pmxa)
-cc Print meter change before page break
-cc increase length of strings for \titles macro
-cc version 1.42
-cc Loosen up input syntax for "X" commands. Subroutine getx()
-cc "B" and "P" in "X" commands
-cc mx09b
-cc Allow multiple rests at start of xtup
-cc Add 64th rest
-cc Fix xtup numbers over rests. (subroutine levrn)
-cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g.
-cc c za / ( c a ...
-cc Allow double dots to be shifted.
-cc Fix spacing with double dotted notes; permit splitting small note.
-cc Fix \dotted printout so it works with old compiler
-cc mx08b
-cc Automatic spaces if needed for shifted accidentals.
-cc Some Dynamics
-cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc)
-cc version 1.41
-cc Allow ":" as last char of path name
-cc Dotted slurs "sb"
-cc Continue bar numbering at movement break "L[integer]Mc"
-cc mx07b
-cc Whole-bar rests with double lines of music. Fixed all options ?
-cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number].
-cc Option to suppress centering full-bar rests. "o"
-cc mx06b
-cc Shift accid on left-shifted chord note.
-cc Rest as first note of xtup.
-cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt
-cc Allow Rb for single bar at movemnet break or end of piece. (islur(25))
-cc Change # of inst at a movement break. noinst is total # and must be used
-cc in 1st movement. ninow is current. nspern(1,...,ninow) is current
-cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to
-cc reprint names in parindent at a movement break. Default is .false.
-cc unless ninow changes, then .true. But can force either with r+/- as
-cc option in 'M'
-cc mx04b
-cc Double-dotted notes, separate+beamed, main+chord, still no extra space.
-cc ??? Don't shift slur ends on whole notes.
-cc (pmxa) Write line number of error in pmxaerr.dat
-cc mx02b
-cc Admit "RD" before "/" (search for "rptfq2:" )
-cc In doslur, for multi-line staves, single notes, check forced stem dir'n
-cc before setting stemup (used to set horiz offset).
-ccccccccccccccccccccccccccccccc
- parameter (nm=24,nks=125,mv=24576,maxblks=4000)
-c
-c FYI /all/ differs in appearance in function ncmid
-c
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
-ccccccccccccc
-cc islur cc
-ccccccccccccc
-c bit meaning
-c 0 slur activity on this note
-c 1 t-slur here.
-c 2 force 0-slope beam starting on this note
-c 3 Double dotted note!
-c 4 grace before main note
-c 5 left repeat
-c 6 right repeat
-c 7 start Volta
-c 8 doublebar
-c 9 end Volta
-c 10 on=>endvoltabox
-c 11 on=>clefchange
-c 12-14 0=>treble, ... , 6=>bass
-c 15 on=> start new block for clef change (maybe diff. voice)
-c 16 literal TeX string
-c 17 1=up, 0=down stem for single note (override) See bit 30!
-c 18 if on, prohibit beaming
-c 19 if on, full bar rest as pause
-c 20 Beam multiplicity down-up
-c 21 Forced multiplicity for any beam including xtups
-c 22-24 Value of forced multiplicity
-c 25 single barline at movement break
-c 26 doubleBAR (see bits 5,6,8)
-c 27-28 Forced beam fine-tune height (1 to 3)
-c 29 Blank rest
-c 30 If on, get stem dir'n from bit 17
-c 31 If on, suppress printing number with xtuplet starting here
-ccccccccccccc
-cc ipl cc
-ccccccccccccc
-cc 0-7 Location in list [0,200]
-c 0-7 Unused
-c 8 left offset main note one headwidth
-c 9 right offset main note one headwidth
-c 10 chord present?
-c 11-16 Forced beam height adjustment (-30 to +30)
-c 17-22 Forced beam slope adjustment (-30 to +30)
-c 23-26 Slur index for Way-after grace. Inserted when slur is started.
-cc 27 Unused?
-c 27 5th bit for slur index for Way-after grace (100712)
-c 28 key change: only in voice 1
-c 29 Grace after main note. (Type A)
-c 30 In forced beam. Signals need to check beam heights
-c 31 Grace way after main note. (stretch to next note, type W)
-ccccccccccccc
-cc iornq cc
-ccccccccccccc
-c 0 Ornament "(". Was user-defined horizontal slur shift on this note
-c until 9/24/97; changed that to irest(21)
-c 1-13 stmgx+Tupf._)
-c 14 Down fermata, was F
-c 15 Trill w/o "tr", was U
-c 16-18 Editorial s,f,n
-c 19-20 >^
-c 21 "?" for editorial accid, w/ or w/o s,f,n
-c 22 Set if ihornb governs ornament height. Same in icrdorn.
-c 23 Set in getorn if ANY note at time of this main note has ornament.
-c This is ONLY used in beamstrt to signal whether to do more
-c tests for whether ihornb is needed. (ihornb is only needed
-c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note)
-c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm.
-c 24 Slur on after or way-after grace. Use as signal to START slur.
-c 25 Tweak orn ht. Same in icrdorn for chord note
-c 26 Insert user-defined space before this note (was 22)
-c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord
-c 28 caesura or breath
-c 29 blank barline (must be iv=1) (would have used islur but no room)
-c 30 "Look-left" option for keyboard rest
-c 31 Set if any note (main or chord) has cautionary accid, for space checks
-ccccccccccccc
-cc irest cc
-ccccccccccccc
-c 0 rest=1, no rest = 0
-c 1 There will be a vertical shift for number of this xtup
-c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n'
-c 7 There is a horizontal shift for xtup number
-c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5
-c 14 Flip up/down-ness of xtup number
-c 15 Single-voice, single note shift X(...)[p]S
-c 16 Start single-voice, multinote shift with this note X(...)[p]:
-c 17 End single-voice, multinote shift after this note. Enter symbol
-c after note. X:
-c 18 User-defined hardspace after last note of bar, *after* this note.
-c Value still stored in udoff(ivx,nudoff(ivx)), not with other
-c hardspaces in udsp, to avoid confusion with time checks.
-c 19 Move the dot. Data stored in ndotmv,updot,rtdot
-c 20 Set if right-shifted main or chord note here. Use for space checks.
-c 21 User-defined hardspace in xtup
-c 22 User-defined slur shift horizontal slur shift.
-c 23 Set on last note before staff-jumping a beam.
-c 24 Set on first note after staff-jumping a beam
-c 25 Suppress rest centering. "ro"
-c 26 Dynamic on this note
-c 27 Set if left-shifted main or chord note here. Use for space checks.
-c 28 Set if xtup starts on this note.
-c 29 Set on lowest-voice note at same time as 1st note after jump-beam.
-c 30 Set on note after end of jump-beam segment, to force new note group
-c 31 Flag for cautionary accidental
-ccccccccccccc
-cc nacc cc
-ccccccccccccc
-c 0-1 0=no accid, 1=fl, 2=sh, 3=na
-c 2 double
-c 3 big
-c 4-9 vertshift-32
-c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32)
-c 17 Midi-only accidental
-c 18 2:1 xtup
-c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note.
-c 20 Set on last note of each seg except last seg of single-slope beam.
-c 21 Set on 1st note of each seg except 1st seg of single-slope beam.
-c 22-26 If .ne.0, printed xtup number for xtup starting on this note.
-c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase
-c multiplicity by 1
-c 28 Set on main note of chord if accidentals are ordered.
-c 29 Tag for chordal accidental shift...means add to autoshifts.
-c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted.
-c If upstem|downstem, main is upper|lower member of 2nd
-c Action is to interchange pitches only when notes are placed.
-ccccccccccccc
-cc mult cc
-ccccccccccccc
-c 0-3 Multiplicity+8 (mult= # of flags)
-c 4 Set if slope adjustment for xtup bracket
-c 5-9 16+slope adjustment
-c 27 Stemlength override
-c 28-30 New stem length.
-ccccccccccccc
-cc isdat1 cc
-ccccccccccccc
-c 13-17 iv
-c 3-10 ip
-c 11 start/stop switch
-c 12 kv-1
-c 19-25 ichar(code$)
-c 26 force direction?
-c 27 forced dir'n = up if on, set in sslur; also
-c final direction, set in doslur when beam is started, used on term.
-c 28-31 ndxslur, set in doslur when beam is started, used on term.
-ccccccccccccc
-cc isdat2 cc
-ccccccccccccc
-c 0 Chord switch. Not set on main note.
-c 1-2 left/right notehead shift. Set only for chord note.
-c 3 tie positioning
-c 4 dotted slur
-c 6-11 voff1 1-63 => -31...+31
-c 12-18 hoff1 1-127 => -6.3...+6.3
-c 19-25 nolev
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
-ccccccccccccc
-cc isdat3 cc
-ccccccccccccc
-c 0 set if midslur (at least one argument)
-c 1 set if curve (2 more args)
-c 2-7 32+first arg (height correction) (1st arg may be negative)
-c 8-10 second arg (initial slope)
-c 11-13 third arg (closing slope)
-c 14-21 tie level for use in LineBreakTies
-c 22-29 ncm for use in LineBreakTies
-ccccccccccccc
-cc isdat4 cc Set these all at turn-on using s option
-ccccccccccccc
-c 0-5 Linebreak seg 1 voff 1-63 => -31...+31
-c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3
-c 16-21 Linebreak seg 2 voff 1-63 => -31...+31
-c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3
-ccccccccccccc
-c icrdat c
-ccccccccccccc
-c 0-7 ip within voice
-c 8-11 ivx (together with 28th bit)
-c 12-18 note level
-c 19 accidental?
-c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
-c 23 shift left
-c 24 shift right
-c 25 arpeggio start or stop
-c 26 flag for moved dot (here, not icrdot, since this is always reset!)
-c 27 Midi-only accidental
-c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices
-c 29 Tag for accidental shift...means add to autoshifts.
-c 31 Flag for cautionary accidental on chord note
-ccccccccccccc
-c icrdot c:
-ccccccccccccc
-c 0-6 10*abs(vertical dot shift in \internote) + 64
-c 7-13 10*abs(horizontal dot shift in \internote) + 64
-c 14-19 vert accidental shift-32
-c 20-26 20*(horiz accidental shift+3.2)
-c 27-29 top-down level rank of chord note w/accid. Set in crdaccs.
-c
-c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
-c
-cccccccccccccccccccccccccccccccc
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*10 figq
- character*1 ulq,sepsymq,sq,chax
- logical beamon,firstgulp,figbass,figchk,
- * isfig,rptnd1,rptprev
- logical loop,lastchar,slint,svolta,evolta,onvolt,
- * cwrest(nm),islast,inlast,optimize
- integer istop(80),numbms(nm),istart(80)
- real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks),
- * tstart(80),squez(80)
- character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq
- character*79 notexq,inameq
- character*40 pathnameq
- character*44 basenameq
- character*24 fmtq
- character*20 voltxtq
- character*120 instrq,titleq,compoq
- common /comlast/ islast,usevshrink
- logical usevshrink,stickyS,OptLineBreakTies,autofbon
- common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- common /comnsp/ space(80),nb,prevtn(nm),
- * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
- common /comstart/ facmtr
- common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb,
- * tautofb,autofbon,t1autofb
- common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS,
- * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
- * rptprev,equalize,rptfq1,rptfq2
- common /combeam/ ibmtyp
- common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
- * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage,
- * OptLineBreakTies,HeaderSpecial
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comas2/ nasksys,wasksys(800),elasksys(800)
- common /comas3/ ask(2500),iask,topmods
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- common /comsln/ is1n1,is2n1,irzbnd,isnx
- common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft,
- * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
- * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit,
- * graspace(37),
- * lenlit(83),multg(37),upg(37),slurg(37),slashg(37),
- * naccg(74),voltxtq(6),litq(83)
- logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2,
- * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial
- common /comivxudorn/ivxudorn(63)
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- character*128 litq,lnholdq
- logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,
- * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb,
- * btest,sluron,setis,nobar1
- common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
- * ndotmv(nm),updot(nm,20),rtdot(nm,20)
- common /compoi/ ispoi
- common /combc/ bcspec
- common /comeon/ eonk,ewmxk
- common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
- * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
- * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
- * rtshfac
- common /comhsp/ hpttot(176)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- common /commus/ musize,whead20
- common /comtol/ tol
- common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12),
- * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41),
- * idynda2(99),levhssav(nm),listcresc,listdecresc
- character*128 txtdynq
- logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize,
- * ismbr,putmbr
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /comcb/ nbc,ibcdata(36)
- common /comclefq/ clefq
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- common /comligfont/ isligfont
- logical isligfont
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /combibarcnt/ ibarcnt
- if (.not.optimize) then
- print*
- print*,'Starting second PMX pass'
- print*
- write(15,'(a)')'Starting second PMX pass'
- end if
- ncalls = ncalls+1
- islast = inlast
- macuse = 0
- isyscnt = 0
- stemmax = 8.2
- stemmin = 3.9
- stemlen = 6.0
- sq = chax(92)
- bcspec = .true.
- topmods = .false.
- ismbr = .false.
- read(12,'(a)')basenameq
- read(12,*)lbase
- read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop,
- * etabot,inbothd,inhnoh,isig
- ilbuf = 1
- ipbuf = 0
- call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,
- * npages,nsyst,musicsize,fracindent,istype0,inameq,
- * clefq,sepsymq,pathnameq,lpath,isig0)
- if (ismidi) then
-c
-c Initial key signature and meter for pickup bar
-c
- call midievent('k',isig,0)
- if (xmtrnum0 .gt. tol) then
-c
-c We have a pickup. Some tricky stuff to get a meter:
-c
- xntrial = xmtrnum0
- do 5 ip2 = 0 , 5
- if (abs(mod(xntrial,1.)) .lt. tol) go to 6
- xntrial = xntrial*2
-5 continue
- print*,'Problem finding meter for pickup bar'
- xntrial = 1.
- ip2 = 0
-6 continue
- call midievent('m',nint(xntrial),2**ip2*mtrdenl)
- else
-c
-c No pickup, enter the starting meter
-c
- call midievent('m',mtrnuml,mtrdenl)
- end if
- end if
-c
-c Set musicsize from value passed in common, due to possible reset by S[n]m16
-c
- musicsize = musize
- read(12,*)npages,widthpt,height,nsyst,
- * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
-c
-c If default width ever changes, must adjust this stmt.
-c
- slfac1 = 0.00569*524./widthpt
- figbass = .false.
- read(13,*)ifig
- if (ifig .eq. 1) then
- figbass = .true.
- open(14,status='SCRATCH')
- write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq//
- * 'sysno by 1'//sq//'ifcase'//sq//'sysno%'
- end if
- lastchar = .false.
- ibcoff = 0
- if (xmtrnum0 .gt. 0.) ibcoff = -1
- open(11,status='SCRATCH')
-c
-c vshrink for the first page is calculated in topfile,
-c and if true set interstaff=10. vshrink affects Titles.
-c Must also save vshrink for page ending.
-c
- call topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur)
-c
-c ninow is working value of # of instruments. noinst is max #, and # at start.
-c
- ninow = noinst
-c
-c Save original printed meter in case movement breaks
-c
- movnmp = mtrnmp
- movdnp = mtrdnp
-c
- if (islast .and. figbass .and. musicsize.eq.16)
- * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%'
-c
- if (islast .and. isligfont) then
- if (musicsize .eq. 16) then
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%'
- else
- write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%'
- end if
- end if
- lenbeat = ifnodur(mtrdenl,'x')
- if (mtrdenl .eq. 2) lenbeat = 16
- lenb1 = mtrnuml*lenbeat
- if (mtrdenl .eq. 2) lenb1 = lenb1*2
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- lenb0 = nint(xmtrnum0*lenbeat)
- if (mtrdenl .eq. 2) lenb0 = lenb0*2
- if (lenb0 .ne. 0) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1'
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
-c
-c Initialize full-program variables
-c
- fixednew = 0.
- scaldold = 0.
- fintstf = -1.
- gintstf = 1.
- nasksys = 0
- ibarcnt = 0
- iline = 0
- movbrk = 0
- isystpg = 0
- ipage = 1
- iccount = 128
- iask = 0
- nhstot = 0
- nb = 1
- if (.not.optimize) jprntb = 81
- idsig = 0
-c
-c Next 5 are raise-barno parameters. irzbnd is integer part of default level.
-c
- irzbnd = 3
- if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4
- is1n1 = 0
- isnx = 0
- SlurCurve = 0.
-c
-c 111109 Made global rather than per gulp
-c
- ndyn = 0
- ispoi = .false.
- slint = .false.
- lrptpend = .false.
- rptnd1 = .false.
- rptfq2 = 'E'
- rptprev = .false.
- onvolt = .false.
- flgndb = .false.
- fbon = .false.
- shifton = .false.
- ornrpt = .false.
- setis = .false.
- lowdot = .false.
- rename = .false.
- nobar1 = .false.
- equalize = .false.
- usevshrink = .true.
- WrotePsslurDefaults = .false.
- OptLineBreakTies = .false.
- HeaderSpecial = .false.
-c
-c vshrink is initialized in topfile
-c
- stickyS = .false.
-c
-c ixrest = 1 or 2 if xtup has started with a rest
-c
- do 1 ivx = 1 , nm
- ixrest(ivx) = 0
- fullsize(ivx) = 1.
-c
-c Set legacy note level to middle c as default
-c
- ndlev(ivx,1) = 29
- ndlev(ivx,2) = 29
-1 continue
- npreslur = 0
- nhssys = 0
- listslur = 0
- do 31 i = 1 , 202
- isdat1(i) = 0
- isdat2(i) = 0
-31 continue
- nsdat = 0
-c
-c Initialize flag for figures in any other voice than 1
-c
- ivxfig2 = 0
-c
-c Initialize for loop over gulps
-c
- firstgulp = .true.
-c
-c Start a gulp
-c
-30 loop = .true.
- notcrd = .true.
- isbjmp = .false.
- isbj2 = .false.
- autofbon = .false.
- tautofb = 0.
- nbars = 0
- nfigs(1) = 0
- nfigs(2) = 0
- ngrace = 0
- ntrill = 0
- ncrd = 0
- nudorn = 0
- nlit = 0
- nvolt = 0
- ibarmbr = 0
- nudsp = 0
-c ndyn = 0 ! 111109
- ntxtdyn = 0
- nbc = 0
- NumArpShift = 0
- do 3 i = 1 , 37
- graspace(i) = 0.
-3 continue
-c
-c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst.
-c and also if nv increases in an 'M' directive.
-c
- do 4 iv = 1 , nv
- call newvoice(iv,clefq(iv),.false.)
-4 continue
-c
-c Check if endsymbol was set earlier
-c
- if (rptnd1) then
- rptnd1 = .false.
- rptfq2 = rptfq1
- else
-c
-c Only use if movbrk>0, to signal default ('RD')
-c
- rptfq2 = 'E'
- end if
- iv = 1
- ivx = 1
-2 if (loop) then
-c
-c Within this loop, nv voices are filled up for the duration of the block.
-c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
-c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..).
-c nbars is for this input block.
-c Only at the beginning of an input block will there be a possible mtr change,
-c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change)
-c
- call getnote(loop)
- if (lastchar) go to 40
- go to 2
- end if
-c
-c Finished an input block (gulp).
-c
- if (ismidi) then
-c
-c Put rests into midi array for 2nd lines that were not used in this gulp.
-c
- do 60 iv = 1 , nv
- if (twoline(iv) .and. nvmx(iv).eq.1) then
- if (firstgulp .and. lenb0.ne.0) then
- call addmidi(midchan(iv,2),0,0,0,
- * (nbars-1.)*lenbar+lenb0,.true.,.false.)
- else
- call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true.,
- * .false.)
- end if
- end if
-60 continue
- end if
- nvolt = 0
- do 28 iv = 1 , nm
- nudoff(iv) = 0
- ndotmv(iv) = 0
-28 continue
-c
-c Put stuff at top of p.1. Must wait until now to have read title info.
-c
- if (ibarcnt .eq. 0) then
- call puttitle(inhnoh,xnsttop(ipage),
- * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- end if
- do 10 ibar = 1 , nbars
- ibarcnt = ibarcnt+1
- bar1syst = ibarcnt .eq. iauto
- ndig = max(0,int(log10(.001+ibarcnt+ibcoff)))
- if (islast)
- * write(11,'(a11,i'//chax(50+ndig)//')')
- * '% Bar count',ibarcnt+ibcoff
- if (ibar .ne. ibarmbr) then
- if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb)
- else
- if (.not.optimize) then
- write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars',
- * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
- jprntb = 0
- end if
- ibcoff = ibcoff+mbrest-1
- if (ibar.eq.1 .and. firstgulp .and.
- * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize
-c
-c The above may be he only case where the space-before option is used in \mbrest
-c
- end if
-c
-c Move the read to after end-of-bar hardspace checks, so we get right poenom
-c at end of a line.
-c if (bar1syst) read(12,*) poenom
-c
-c Check for clef at start of bar. No slide yet. Also flags at end of prev.
-c bar. This block is run at the start of every bar. May fail for flag at
-c end of last bar. To account for necc. hardspaces, compute and store
-c nhssys = # of hard spaces for this system
-c hesk(nhssys) = elemskips avialable
-c hpts(nhssys) = hard points needed, including notehead
-c Here, merely insert placeholder into output. Later, when poe is computed,
-c compute additional pts and store them in hpttot(1...nhstot). Finally in
-c subroutine askfig, write true pts where placeholders are.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(1,ibar-1)
- clchb = btest(islur(1,ioff+1),15)
- putmbr = .false.
- if (ismbr) then
- if (clchb) then
-c
-c Clef change and multi-bar rest coming up. Kluge to get space at end of rest.
-c
- write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest'
- * //sq//'def'//sq//'mbrest#1#2#3{%'
- write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55,
- * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%'
- end if
- ismbr = .false.
- putmbr = .true.
- end if
- if (ibar .eq. ibarmbr) ismbr = .true.
-c
-c Set flag here so at start of next bar, if there's a clef change, can add space
-c after the mbr with the above kluge
-c
- if (.not.(clchb .or. flgndb)) go to 23
-c
-c Must check available space
-c
- ptsndb = 0.
-c
-c Zero out block signal
-c
- if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15)
-c
-c In this loop, we determine how much hardspace is needed (if any)
-c 9/7/97 Note that for last bar in input block, if number of lines of
-c music decreases in new block, highest numbered ones won't be checked
-c since the loop below covers the new nvmx(iv), not necessarily the old
-c one.
-c 4/18/98 Apparently nmxsav was a solution to the above problem
-c
- do 16 iv = 1 , nv
- do 16 kv = 1 , nvmxsav(iv)
- ivx = ivmxsav(iv,kv)
- ptsndv = flgndv(ivx)*wheadpt
- ioff = 0
- if (ibar .gt. 1) then
- ioff = nib(ivx,ibar-1)
- ip = ioff
- if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2)
-c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255))
- prevtn(ivx) = tnote(ipl2(ivx,ip))
-c
-c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar.
-c
- end if
-c
-c Only allow clef changes when ivx <= nv
-c
- if (ivx .le. nv) then
- clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11)
- if (clchv(iv)) then
-c
-c Clef change in this voice. Turn off signal. Get space avail.
-c
- islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11)
- if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv =
- * ptsndv+clefend*wheadpt
- end if
- end if
- ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac)
-16 continue
-c
-c ???? where is nb set??? nb probably in left over from makeabar
-c
- esk = feon(space(nb)*squez(nb))
- ptsdflt = esk*poenom-wheadpt
-c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then
- if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0
- * .and. .not.putmbr) then
-c
-c Must ADD hardspace! So put in a placeholder, and store params for later.
-c
- if (islast) write(11,'(a)')sq//'xardspace{ pt}%'
- nhssys = nhssys+1
- if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then
- hesk(nhssys) = esk
- hpts(nhssys) = ptsndb+wheadpt
- else
- hesk(nhssys) = eskgnd
- hpts(nhssys) = ptsgnd+wheadpt
- end if
- fixednew = fixednew+hpts(nhssys)
- scaldold = scaldold+hesk(nhssys)
- end if
- if (clchb) then
- do 17 iv = 1 , nv
- if (clchv(iv)) then
- notexq = sq//'znotes'
- lnote = 7
- do 24 iiv = 2 , iv
- notexq = notexq(1:lnote)//sepsymq(iiv-1)
- lnote = lnote+1
-24 continue
-c
-c Recompute ioff since it will vary from voice to voice
-c
- if (ibar .eq. 1) then
- ioff = 0
- else
- ioff = nib(iv,ibar-1)
- end if
-c
-c Must call clefsym to get nclef, even if there is a movement break
-c
- call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
- if (movbrk.eq.0 .and.
- * islast)
- * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%'
- call wsclef(iv,ninow,clefq,nclef)
- end if
-17 continue
- if (islast) write(11,'(a)')sq//'pmxnewclefs'
- end if
-23 continue
-c
-c End of loop for end-of-bar hardspaces and non-movbrk clef symbol.
-c
- if (bar1syst) then
- read(12,*) poenom
- end if
-c
-c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1)
-c
- if (ibar .eq. 1) then
- islnow = islur(1,1)
- iornqnow = iornq(1,1)
- else
- islnow = islur(1,nib(1,ibar-1)+1)
- iornqnow = iornq(1,nib(1,ibar-1)+1)
- end if
-c
-c Check for R-symbols set at end of prior input block
-c
- if (movbrk.eq.0 .and. rptfq2.ne.'E') then
- if (rptfq2 .eq. 'D') then
- islnow = ibset(islnow,26)
- else if (rptfq2 .eq. 'r') then
- islnow = ibset(islnow,6)
- else if (rptfq2 .eq. 'd') then
- islnow = ibset(islnow,8)
- else if (rptfq2 .eq. 'b') then
- islnow = ibset(islnow,25)
- else
- print*
- print*,'Illegal symbol with "R" at end of input block:',
- * rptfq2
- call stop1()
- end if
- rptfq2 = 'E'
- end if
- if (iand(islnow,352) .ne. 0) then
-c
-c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set
-c
- lrpt = btest(islnow,5)
- rrpt = btest(islnow,6)
- lrptpend = lrpt.and.bar1syst
- if (lrpt .and. .not.lrptpend) then
- if (rrpt) then
- if (islast) write(11,'(a)')sq//'setleftrightrepeat'
- fixednew = fixednew+wheadpt*lrrptfac-0.4
- else
- if (islast) write(11,'(a)')sq//'setleftrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- end if
- else if (rrpt) then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- fixednew = fixednew+wheadpt*rptfac-0.4
- else if (btest(islnow,8)) then
- if (islast) write(11,'(a)')sq//'setdoublebar'
- fixednew = fixednew+wheadpt*dbarfac-0.4
- end if
- else if (btest(islnow,26)) then
-c
-c doubleBAR
-c
- if (islast) write(11,'(a)')sq//'setdoubleBAR'
- fixednew = fixednew+wheadpt*ddbarfac-0.4
- else if (btest(iornqnow,29)) then
-c
-c no bar line
-c
-c-- if (islast) write(11,'(a)')sq//'setzalaligne'
-c++
- if (islast) then
- if (movbrk .eq. 0) then
- write(11,'(a)')sq//'setzalaligne'
- else
-c
-c Encountered "Rz" at start of input block at start of new movement, Must
-c use newmovement macro with arg 4 rather than setzalaligne, since former
-c already redefines stoppiece.
-c
- rptfq2 = 'z'
- end if
- end if
-c++
- fixednew = fixednew-0.4
- end if
-c
-c 1st and 2nd endings
-c
- svolta = btest(islnow,7)
- evolta = btest(islnow,9)
- if (evolta) then
- if (btest(islnow,10)) then
- if (islast) write(11,'(a)')sq//'endvoltabox'
- else
- if (islast) write(11,'(a)')sq//'endvolta'
- end if
- onvolt = .false.
- end if
- if (svolta) then
- nvolt = nvolt+1
- lvoltxt = index(voltxtq(nvolt),' ')-1
- if (lvoltxt .eq. 1) then
- if (islast) write(11,'(a)')sq//'Setvolta'
- * //voltxtq(nvolt)(1:1)//'%'
- else
- if (islast) write(11,'(a)')sq//'Setvolta'//'{'//
- * voltxtq(nvolt)(1:lvoltxt)//'}%'
- end if
- onvolt = .true.
- end if
- if (ibar .gt. 1) then
- ipnow = nib(1,ibar-1)+1
- else
- ipnow = 1
- end if
- iplnow = ipl(1,ipnow)
- if (bar1syst) then
-c
-c If listslur>0, then there is at least one slur or tie carried over the break
-c
- ispstie = .false.
- if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0
- * .and. islast)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat,
- * ispstie,sepsymq)
- iline = iline+1
-c
-c End an old system, Start a new system
-c
- if (iline .ne. 1) then
-c
-c Not first line.
-c Get corrected poe = points/elemskip for *previous* system
-c
- wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- isyscnt = isyscnt+1
- poevec(isyscnt) = poe
-c
-c Transfer data for system into global arrays to hold until very end
-c
- do 9 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
-c
-c Only admit negative ask if it was user-defined space, signalled by elask<=0.
-c
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-9 continue
- do 25 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-25 continue
-c
-c Reset counters for new system
-c
- scaldold = 0.
- fixednew = 0.
- nasksys = 0
- nhssys = 0
- end if
-c
-c End of if block for first bar of non-first system. Still 1st bar, any system
-c
- if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%'
- isystpg = isystpg+1
-c
-c Try moving the next stmt way down, to fix a bug and get \eject printed at
-c end of single-system page.
-c if (isystpg .eq. nsystp(ipage)) isystpg = 0
- read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk
- if (iline .gt. 1) fracindent=frac
- if (figbass) then
- ifigdr(1,iline) = 4
- ifigdr(2,iline) = 4
- end if
- slfac = slfac1*musicsize*elsktot
- if (iline .ne. 1) then
-c
-c For the line just _finished_, put figdrop in separate file.
-c
- if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)')
- * sq//'figdrop=',ifigdr(1,iline-1),
- * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%'
-c
-c Check slurs in top staff for interference w/ barno. Only check when
-c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS
-c keep track of ons and offs when |isig|<=3.
-c
- ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1
- isnx = 0
- if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then
-c
-c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1
-c Look for termination in remainder of this input block. If not found,
-c just use is1n1. Remember, haven't slid down yet.
-c
- ioff = 0
- if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1)
- do 50 isdat = 1 , nsdat
- if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv))
- * .and. .not.btest(isdat1(isdat),11)
- * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then
-c
-c Found slur ending. Just check note height, can't do fine adjustments.
-c
-c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19))
- is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19))
- go to 51
- end if
-50 continue
-c
-c If exiting loop normally, did not find end of slur. c'est la vie.
-c
-51 continue
- isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd)
- if (isnx .gt. 0) then
-c
-c AHA! Slur likely to interfere with barno.
-c
-c Modified 090525 to use \bnrs
-c
- slint = .true.
- fmtq = '(a16,i1,a14)'
- if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)'
- if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{',
- * irzbnd+isnx,'.5'//sq//'internote}%'
-c if (islast) then
-c if (isnx .le. 9) then
-c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%'
-c else
-c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%'
-c end if
-c end if
-c
- end if
- end if
- if (movbrk .gt. 0) then
-c
-c movbrk = 0
-c Move the reset down, so can use movbrk>0 to stop extra meter prints.
-c
-c New movement. Redefine stoppiece, contpiece. These will be called either
-c explicitly or as part of alaligne.
-c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat.
-c This is passed to \newmovement.
-c
- if (rptfq2 .eq. 'E') rptfq2 = 'D'
- indsym = index('Ddrbz',rptfq2)-1
- rptfq2 = 'E'
-c
-c Also check for Rd or Rr set the normal way
-c
- if (btest(islnow,8)) then
- indsym = 1
- else if (btest(islnow,6)) then
- indsym = 2
- end if
- if (indsym .lt. 0) then
- print*
- print*,'Illegal end symbol before "/"'
- call stop1()
- end if
-c
-c Check for continuation (no bar number reset)
-c
- if (islast.and.
- * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1'
- * //sq//'startbarno'//sq//'barno%'
- if (movgap .lt. 10) then
- if (islast) write(11,'(a12,2i1,a1)')
- * sq//'newmovement',movgap,indsym,'%'
- else
- if (islast) write(11,'(a13,i2,a1,i1,a1)')
- * sq//'newmovement{',movgap,'}',indsym,'%'
- end if
-c
-c Change generalmeter if necessary
-c
- if (islast) call wgmeter(mtrnmp,mtrdnp)
-c
-c (Moved all name-writing to getnote, right when 'M' is detected)
-c
- if (btest(iplnow,28)) then
-c
-c Key signature at movement break
-c
- iplnow = ibclr(iplnow,28)
- if (isig .gt. 0) then
- if (islast) write(11,'(a18,i1,a2)')
- * sq//'generalsignature{',isig,'}%'
- else
- if (islast) write(11,'(a18,i2,a2)')
- * sq//'generalsignature{',isig,'}%'
- end if
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- end if
- if (parmov .ge. -.1) then
-c
-c Resent paragraph indentation
-c
- ipi = parmov*widthpt+.1
- if (ipi .lt. 10) then
- if (islast) write(11,'(a11,i1,a2)')
- * sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- if (islast)
- * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- if (islast)
- * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- end if
- end if
- if (isystpg .eq. 1) then
-c
-c First line on a page (not 1st page, still first bar). Tidy up old page
-c then eject.
-c
-c Removed this 5/13/01 as it was causing double endvoltas. This probably
-c is only needed at the end in case there is no endvolta specified.
-c if (onvolt) then
-cc if (islast) write(11,'(a)')sq//'endvoltabox%'
-cc onvolt = .false.
-c end if
-c
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page. Ugly repeated coding here.
-c
- mtrnms = mtrnuml
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- mtrnuml = mtrnms
- if (movbrk .eq. 0 .and. islast)
- * call wgmeter(mtrnmp,mtrdnp)
- end if
-c
-c Key signature change?
-c
- if (btest(iplnow,28) .and. movbrk.eq.0) then
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')
- * notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-'//sq//'afterruleskip}'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue%'
- else if (mtrnuml.gt.0 .and. movbrk.eq.0) then
-c
-c Meter change but no signature change
-c
- if (islast)
- * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'//
- * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq//
- * 'barnoadd%'
- if (islast)
- * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'//
- * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%'
- else
- if (islast) write(11,'(a)')sq//'stoppiece%'
- end if
-c
-c This is the key spot when vshrink is used. Value of vshrink here comes from
-c just after the prior pagebreak, i.e., it is not affected by "Av"
-c that may have been entered at this pagebreak, since that only affects usevshrink.
-c So choose page *ending* (with or without \vfill) depending on old vshrink. Then
-c check value of usevshrink to reset vshrink if necessary for the new page, where
-c we have to set \interstaff and later call puttitle.
-c Top of first page needs special treatment. For this we use
-c novshrinktop, which was set in g1etnote on the first pass, since on
-c second pass, vshrink at top of page one is dealt with in topfile, which is called
-c *before* any reading in any "Av" at the top of the first input block.
-c
- if (.not.vshrink) then
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject%'
- else
- if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%'
- end if
- ipage = ipage+1
-c
-c Now that page is ejected, compute new vshrink
-c
- vshrink = xintstaff(ipage).gt.20 .and. usevshrink
- if (vshrink) then
- xinsnow = 10
- else
- xinsnow = xintstaff(ipage)
- end if
- if (fintstf.gt.0 .and. ipage.gt.1) then
- xinsnow = xinsnow*fintstf/gintstf
- fintstf = -1.
- end if
- if (xinsnow .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else if (xinsnow .lt. 99.95) then
- fmtq = '(a,f4.1,a)'
- else
- fmtq = '(a,f5.1,a)'
- end if
-c
-c Vertical spacing parameters, then restart
-c
- if (islast) write(11,fmtq)sq//'interstaff{',xinsnow,
- * '}'//sq//'contpiece'
-c
-c Check for meter change at start of a new PAGE
-c
- if (mtrnuml .gt. 0) then
-c
-c Meter change at start of a new page
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) write(11,'(a)')sq//'newtimes2%'
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- end if
- end if
- end if
-c
-c If no real titles here, which there probably will never be, make vertical
-c space at page top with \titles{...}. headlog=.false.<=>no real titles
-c
- call puttitle(inhnoh,xnsttop(ipage),etatop,
- * sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
- if (HeaderSpecial)
-c
-c Write special header for first page
-c
- * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%'
- else
-c
-c First bar of system, not a new page, force line break
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast) write(11,'(a)')notexq(1:lnote)
- * //chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
- if (mtrnuml .ne. 0) then
-c
-c Meter+sig change, new line, may need mods if movement break here.
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) then
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'xchangecontext'//sq//
-c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'
- * 'addspace{-'//sq//'afterruleskip}'
-c * //sq//'writezbarno{}'//sq//'zalaligne%'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- write(11,'(a)')sq//'addspace{-'//sq
- * //'afterruleskip}%'
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'zchangecontext'
- end if
- else
- if (islast) write(11,'(a)')sq//'xchangecontext'//sq//
-c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'//
- * 'addspace{-'//sq//'afterruleskip}'
-c * sq//'writezbarno{}'//sq//'zalaligne%'
- * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%'
- end if
- else if (mtrnuml .eq. 0) then
-c
-c No meter change
-c
- if (islast) write(11,'(a)')sq//'alaligne'
- else
-c
-c New meter, no new sig, end of line, not new page.
-c
-c \generalmeter{\meterfrac{3}{4}}%
-c \xchangecontext\addspace{-\afterruleskip}%
-c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}%
-c \zchangecontext
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) then
- write(11,'(a)')
- * sq//'let'//sq//'bnat'//sq//'barnoadd'
- * //sq//'def'//sq//'barnoadd{'//sq//'empty}%'
- write(11,'(a)')sq//'xchangecontext'//sq//
- * 'addspace{-'//sq//'afterruleskip}'//sq//
- * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat'
- call wgmeter(mtrnmp,mtrdnp)
- write(11,'(a)')sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'zchangecontext'
- end if
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- else
- if (islast) write(11,'(a)')sq//'alaligne'
- end if
- end if
- end if
-c
-c Modified 090525 to use \bnrs
-c
- if (slint) then
- slint = .false.
- if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq//
- * 'raisebarno{',irzbnd,'.5'//sq//'internote}%'
- end if
- movbrk = 0
- end if
-c
-c Clean up if we squelched bar number reset at movement break
-c
- if (nobar1) then
- if (islast) write(11,'(a)')sq//'startbarno1'
- nobar1 = .false.
- end if
- read(12,*,end=14)iauto
-14 continue
-c
-c We come thru here for the 1st bar of every system, so initialize is1n1
-c
- is1n1 = 0
-c
-c Brought down from above
-c
- if (isystpg .eq. nsystp(ipage)) isystpg = 0
-c
-c Check for linebreak ties
-c
- if (ispstie)
- * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat,
- * ispstie,sepsymq)
- else
-c
-c Not first bar of system
-c
- if (btest(iplnow,28)) then
-c
-c Signature change
-c
- if (mtrnuml .ne. 0) then
-c
-c Meter+signature change mid line, assume no movement break
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- notexq = sq//'generalsignature{'
- lnote = 18
- if (isig .lt. 0) then
- notexq = notexq(1:18)//'-'
- lnote = 19
- end if
- if (islast) then
- iptemp = 48+abs(isig)
- charq = chax(iptemp)
- notexq = notexq(1:lnote)//charq//'}%'
- lnote = lnote+3
- write(11,'(a)')notexq(1:lnote)
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- write(11,'(a)')sq//'xchangecontext%'
- end if
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
- xb4mbr = (facmtr+naccs*.24)*musicsize
- end if
- else
-c
-c Signature change only
-c
- notexq = sq//'xbar'//sq//'addspace{-'//sq//
- * 'afterruleskip}'//sq//'generalsignature{'
- lnote = 49
- if (isig .lt. 0) then
- notexq = notexq(1:49)//'-'
- lnote = 50
- end if
- if (islast)
- * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%'
- if (islast .and. LaterInstTrans) then
- call Writesetsign(nInstTrans,iInstTrans,iTransKey,
- * LaterInstTrans)
- end if
- if (islast) write(11,'(a)')sq//'zchangecontext'//sq
- * //'addspace{-.5'// sq//'afterruleskip}%'
- if (ibar .eq. ibarmbr) then
-c
-c Compute space for multibar rest
-c
- if (lastisig*isig .ge. 0) then
- naccs = max(abs(lastisig),abs(isig))
- else
- naccs = abs(lastisig-isig)
- end if
- xb4mbr = naccs*.24*musicsize
- end if
- end if
- else if (mtrnuml .eq. 0) then
-c
-c No meter change
-c
- if (islast) write(11,'(a)')sq//'xbar'
- else
-c
-c Change meter midline
-c
- call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
- if (movbrk .eq. 0) then
- if (islast) call wgmeter(mtrnmp,mtrdnp)
- if (mtrdnp .gt. 0) then
- if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%'
- if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
- else
- if (islast) write(11,'(a)')sq//'xbar'
- end if
- end if
- end if
- end if
-c
-c Now that xbar's are written, can put in left-repeats at line beginnings
-c
- if (lrptpend) then
- if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1'
- * //sq//'leftrepeat'
- lrptpend = .false.
- end if
- if (ibar .gt. 1) then
-c
-c For bars after first, slide all stuff down to beginning of arrays
-c
- do 11 iv = 1 , nv
- do 11 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- ioff = nib(ivx,ibar-1)
- do 12 ip = 1 , nib(ivx,ibar)-ioff
- nolev(ivx,ip) = nolev(ivx,ip+ioff)
- nodur(ivx,ip) = nodur(ivx,ip+ioff)
- nacc(ivx,ip) = nacc(ivx,ip+ioff)
- irest(ivx,ip) = irest(ivx,ip+ioff)
- islur(ivx,ip) = islur(ivx,ip+ioff)
- ipl(ivx,ip) = ipl(ivx,ip+ioff)
- iornq(ivx,ip) = iornq(ivx,ip+ioff)
- mult(ivx,ip) = mult(ivx,ip+ioff)
-c if (ivx.le.2 .and. figbass)
-c * isfig(ivx,ip) = isfig(ivx,ip+ioff)
- if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then
- if (ivx.eq.1) then
- isfig(1,ip) = isfig(1,ip+ioff)
- else
- isfig(2,ip) = isfig(2,ip+ioff)
- end if
- end if
-12 continue
- if (ivx.le.nv .and. ncc(iv).gt.1) then
- islide = 0
- do 13 icc = 1 , ncc(iv)
- if (tcc(iv,icc) .le. lenbar) then
-c
-c This time will drop <=0 when slid.
-c
- islide = icc-1
- ncmidcc(iv,1) = ncmidcc(iv,icc)
- else
- tcc(iv,icc-islide) = tcc(iv,icc)-lenbar
- ncmidcc(iv,icc-islide) = ncmidcc(iv,icc)
- end if
-13 continue
- ncc(iv) = ncc(iv)-islide
- tcc(iv,1) = 0.
- end if
-11 continue
- do 15 ig = 1 , ngrace
- ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1)
- if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2)
-15 continue
- do 21 il = 1 , nlit
- iplit(il) = iplit(il)-nib(ivlit(il),ibar-1)
- if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2)
-21 continue
- do 22 it = 1 , ntrill
- iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1)
- if (ibar .gt. 2) iptrill(it) =
- * iptrill(it)+nib(ivtrill(it),ibar-2)
-22 continue
- do 27 icrd = 1 , ncrd
-c ivx = iand(15,ishft(icrdat(icrd),-8))
- ivx = iand(15,ishft(icrdat(icrd),-8))
- * +16*igetbits(icrdat(icrd),1,28)
- ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- icrdat(icrd) = iand(not(255),icrdat(icrd))
- icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd))
-27 continue
- do 29 iudorn = 1 , nudorn
-c ivx = iand(15,ishft(kudorn(iudorn),-8))
- ivx = ivxudorn(iudorn)
- ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1)
- if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
- kudorn(iudorn) = iand(not(255),kudorn(iudorn))
- kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn))
-29 continue
- do 42 idyn = 1 , ndyn
- idynd = idyndat(idyn)
-c ivx = iand(15,idynd)
- ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10)
- ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
-c
-c The following construction avoids array bound errors in some compilers
-c
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(idynd,8,4,ipnew)
- idyndat(idyn) = idynd
-42 continue
- do 43 itxtdyn = 1 , ntxtdyn
- idynd = ivxiptxt(itxtdyn)
-c ivx = iand(15,idynd)
- ivx = iand(31,idynd)
-c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
- ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
-c call setbits(idynd,8,4,ipnew)
- call setbits(idynd,8,5,ipnew)
- ivxiptxt(itxtdyn) = idynd
-43 continue
- do 41 isdat = 1 , nsdat
- isdata = isdat1(isdat)
- ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1)
- ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(isdata,8,3,ipnew)
- isdat1(isdat) = isdata
-41 continue
- do 44 ibc = 1 , nbc
-c ivx = iand(15,ibcdata(ibc))
- ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1)
- if (ibar .gt. 2) then
- ipnew = ipnew+nib(ivx,ibar-2)
- end if
- ipnew = dim(ipnew,0)
- call setbits(ibcdata(ibc),8,4,ipnew)
-44 continue
- do 45 iarps = 1 , NumArpShift
- IpArpShift(iarps) =
- * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1)
- if (ibar .gt. 2) then
- IpArpShift(iarps) =
- * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2)
- end if
-45 continue
-c
-c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left.
-c If there are figs left, it will reset all times relative to start of
-c current bar.
-c
- do 46 ivx = 1 , 2
- if (figbass) then
- islide = 0
- do 20 jfig = 1 , nfigs(ivx)
- if (itfig(ivx,jfig) .lt. lenbar) then
-c
-c This figure was already used
-c
- islide = jfig
- else
- itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar
- figq(ivx,jfig-islide) = figq(ivx,jfig)
- itoff(ivx,jfig-islide) = itoff(ivx,jfig)
- ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig)
- end if
-20 continue
- nfigs(ivx) = nfigs(ivx)-islide
- end if
- if (nfigs(2) .eq. 0) go to 47
-46 continue
-47 continue
- end if
-c
-c End of sliding down for bars after first in gulp.
-c
-c The following may not be needed by makeabar, but just in case...
-c
- if (firstgulp .and. lenb0.ne.0) then
- if (ibar .eq. 1) then
- lenbar = lenb0
- else
- lenbar = lenb1
- end if
- end if
-c
-c Equal line spacing stuff
-c
- if (equalize .and. bar1syst) then
- if (isystpg .eq. 1) then
- write(11,'(a)')sq//'starteq%'
- else if (isystpg .eq. nsystp(ipage)-1) then
- write(11,'(a)')sq//'endeq%'
- end if
- end if
- call make1bar(ibmrep,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart)
- call make2bar(ninow,tglp1,tstart,cwrest,squez,
- * istop,numbms,istart,clefq)
-c
-c Hardspace before barline?
-c
- hardb4 = 0.
- do 35 iv = 1 , nv
- do 35 kv = 1 , nvmx(iv)
- ivx = ivmx(iv,kv)
- if (btest(irest(ivx,nn(ivx)),18)) then
- nudoff(ivx) = nudoff(ivx)+1
- hardb4 = max(hardb4,udoff(ivx,nudoff(ivx)))
- end if
-35 continue
- if (hardb4 .gt. 0.) then
- if (islast) write(11,'(a11,f5.1,a4)')sq
- * //'hardspace{',hardb4,'pt}%'
- fixednew = fixednew-hardb4
- end if
-10 continue
- firstgulp = .false.
- lenb0 = 0
- go to 30
-40 close(12)
- close(13)
- ilbuf = 1
- ipbuf = 0
- wdpt = widthpt
- if (iline .eq. 1) wdpt = widthpt*(1-fracindent)
- poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
- * (elsktot+fbar*nbarss-scaldold)
- poevec(nsyst) = poe
- if (.not.islast) then
- close(11)
- close(16)
- if (figbass) close(14)
- return
- end if
- do 19 ia = 1 , nasksys
- iask = iask+1
- ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
- if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
-19 continue
- do 26 ia = 1 , nhssys
- nhstot = nhstot+1
- hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
-26 continue
- if (islast .and.
- * onvolt) write(11,'(a)')sq//'endvoltabox'
- if (rptfq2 .ne. 'E') then
-c
-c Terminal repeat. Right or double?
-c
- if (rptfq2 .eq. 'r') then
- if (islast) write(11,'(a)')sq//'setrightrepeat'
- * //sq//'endpiece'
- else if (rptfq2 .eq. 'd') then
- if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece'
- else if (rptfq2 .eq. 'b') then
- if (islast) write(11,'(a)')sq//'endpiece'
- else if (rptfq2 .eq. 'z') then
- if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece'
- else
-c else if (rptfq2 .ne. 'D') then
- print*
- print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2
- if (islast) write(11,'(a)')sq//'Endpiece'
- end if
- else
- if (islast) write(11,'(a)')sq//'Endpiece'
- end if
- if (.not.vshrink) then
- xnstbot = xnsttop(ipage)*etabot/etatop
- if (xnstbot .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- if (islast) write(11,fmtq)sq//'vskip',xnstbot,
- * sq//'Interligne'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- else
- if (islast) write(11,'(a)')
- * sq//'vfill'//sq//'eject'//sq//'endmuflex'
- if (islast) write(11,'(a)')sq//'bye'
- end if
- rewind(11)
- if (figbass) then
- write(14,'(a9,i2,a10,i2,1x,a5)')
- * sq//'figdrop=',ifigdr(1,iline),
- * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%'
- rewind(14)
- end if
- call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
- if (.not.optimize) then
- print*
- print*,'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- print*,'Done with second PMX pass.'
- write(15,'(/,a)')'Writing '
- * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
- write(15,'(a)')' Done with second PMX pass. Now run TeX'
- end if
- return
- end
- subroutine poestats(nsyst,poe,poebar,devnorm)
- parameter (nks=125)
-c
-c Compute avg. & norm. std. dev. of poe.
-c
- real*4 poe(nks)
- sumx = 0.
- sumxx = 0.
- do 1 isyst = 1 , nsyst
- sumx = sumx+poe(isyst)
- sumxx = sumxx+poe(isyst)**2
-1 continue
-2 continue
- devnorm = sqrt(nsyst*sumxx/sumx**2-1)
- poebar = sumx/nsyst
- return
- end
- subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq,
- * twooftwo,icashft)
-c
-c Analyzes chords, data to be used with slurs on chords and plain chords.
-c Check for 2nds, shift notes if neccesary.
-c ipl(10) chord present
-c irest(20) set if any note is right shifted
-c irest(27) set if any note is left shifted
-c ipl(8|9) left|right shift main note
-c icrdat(23|24) ditto chord note
-c udq is updown-ness, needed to analyze 2nds.
-c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note.
-c icrdot(icrd)(27-29) sequence order of chord note if accid, top down
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- logical btest,is2nd,twooftwo
- integer*4 kicrd(10),levtabl(88)
- character*1 udq
- do 11 i = 1 , 88
- levtabl(i) = 0
-11 continue
- do 1 icrd1 = 1 , ncrd
- ivx1 = iand(15,ishft(icrdat(icrd1),-8))
- * +16*igetbits(icrdat(icrd1),1,28)
- ip1 = iand(255,icrdat(icrd1))
- if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2
-1 continue
- print*
- print*,
- * 'Cannot find first chord note in precrd. Send source to Dr. Don!'
- call stop1()
-2 continue
- maxlev = nolevm
- minlev = nolevm
- levtabl(nolevm) = -1
- is2nd = .false.
- naccid = 0
- levmaxacc = -100
- levminacc = 1000
-c
-c Check 1st 3 bits of nacc for accid on main note of chord.
-c
- if (iand(7,nacc) .gt. 0) then
- naccid = 1
-c
-c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main,
-c otherwise icrd value for note with accidental.
-c
- kicrd(1) = 0
- levmaxacc = nolevm
- levminacc = nolevm
-c
-c Start the level-ranking
-c
- icrdot0 = 1
- end if
- do 3 icrd2 = icrd1 , ncrd
- nolev = igetbits(icrdat(icrd2),7,12)
- levtabl(nolev) = icrd2
- maxlev = max(maxlev,nolev)
- minlev = min(minlev,nolev)
-c
-c Check for accidental
-c
- if (btest(icrdat(icrd2),19)) then
- naccid = naccid+1
- levmaxacc = max(levmaxacc,nolev)
- levminacc = min(levminacc,nolev)
-c
-c Add this icrd to list of values for notes with accid's.
-c
- kicrd(naccid) = icrd2
- if (.not.btest(nacc,28)) then
-c
-c Order not forced, so get the level-ranking, top down
-c
- iorder = 1
- do 12 iaccid = 1 , naccid-1
- if (kicrd(iaccid) .eq. 0) then
- if (nolevm .gt. nolev) then
- iorder = iorder+1
- else
- icrdot0 = icrdot0+1
- end if
- else
- if (igetbits(icrdat(kicrd(iaccid)),7,12)
- * .gt. nolev) then
- iorder = iorder+1
- else
- iold = igetbits(icrdot(kicrd(iaccid)),3,27)
- call setbits(icrdot(kicrd(iaccid)),3,27,iold+1)
- end if
- end if
-12 continue
- call setbits(icrdot(icrd2),3,27,iorder)
- end if
- end if
-c
-c Exit loop if last note in this chord
-c
- if (icrd2 .eq. ncrd) go to 4
- if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or.
-c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4
- * igetbits(icrdat(icrd2+1),4,8)
- * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4
-3 continue
- print*
- print*,'Failed to find last chord note. Send source to Dr. Don!'
- call stop1()
-4 continue
-c
-c Now icrd1, icrd2 define range of icrd for this chord.
-c
-c Bypass autos-shifting if any manual shifts are present
-c
- if (btest(irest,20) .or. btest(irest,27)) go to 10
-c
-c Check for 2nds
-c
- do 5 ilev = 1 , 87
- if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then
-c
-c There is at least one 2nd..
-c
- if (udq .eq. 'u') then
-c
-c Upstem. Start with 2nd just found and go up, rt-shifting upper
-c member of each pair
-c
- ile = ilev
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,20)
-7 continue
- if (levtabl(ile+1) .lt. 0) then
-c
-c Upstem, & upper member is main so must be rt-shifted. This would move
-c stem too, so we rt-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,30)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24)
- else
-c
-c Upper member is chord note, must be rt-shifted
-c
- icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24)
- end if
- ile = ile+1
-8 continue
- ile = ile+1
- if (ile .lt. 87) then
- if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then
- go to 7
- else
- go to 8
- end if
- end if
- go to 10
- else
-c
-c Downstem. Start at top and work down, left-shifting lower member of each pair.
-c We know that lowest pair is at (ilev,ilev+1).
-c
- ile = 88
-c
-c Set main-note flag for ANY right-shift
-c
- irest = ibset(irest,27)
-9 continue
- if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then
- if (levtabl(ile-1) .lt. 0) then
-c ipl = ibset(ipl,8)
-c
-c Dnstem, & lower member is main so must be left-shifted. This would move
-c stem too, so we left-shift the OTHER note, and set flag that signals
-c to interchange pitches just when these two notes are placed.
-c
- nacc = ibset(nacc,31)
- icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23)
- else
-c
-c Lower member is chord note, must be shifted
-c
- icrdat(levtabl(ile-1)) =
- * ibset(icrdat(levtabl(ile-1)),23)
- end if
- ile = ile-1
- end if
- ile = ile-1
- if (ile .ge. ilev+1) go to 9
- go to 10
- end if
- end if
-5 continue
-10 continue
-c
-c Done with 2nds, now do accid's. Call even if just one, in case left shifts.
-c
-c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid,
- if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid,
- * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft)
- return
- end
- subroutine printl(string)
- character*(*) string
-c
-c Send string to console and to log file
-c
- print*,string
- write(15,'(a)')string
- return
- end
- subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comtol/ tol
- common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20),
- * ArpShift(20)
- logical lowdot,IsArpShift
- character*80 soutq
- character*79 notexq
- character*8 symq(2)
- character*1 chax
- data symq /'raisearp','arpeggio'/
-
-c
-c Find which iarp, if any
-c
- do 1 iarp = 1 , narp
- if (abs(tnow-tar(iarp)).lt.tol) go to 2
-1 continue
-c
-c If here, this is the *first* call for this arp.
-c
- narp = narp+1
- tar(narp) = tnow+tol*.5
- ivar1(narp) = iv
- ipar1(narp) = ip
- levar1(narp) = nolev
- ncmar1(narp) = ncm
- return
-2 continue
-c
-c If here, this is *second* call at this time, iarp points to values from 1st.
-c
-c Check for shift. Set IsArpShift and iarps
-c
- do 3 iarps = 1 , NumArpShift
- if (IvArpShift(iarps) .eq. ivar1(iarp) .and.
- * IpArpShift(iarps) .eq. ipar1(iarp)) then
- IsArpShift = .true.
- notexq = chax(92)//'loffset{'
- write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{'
- lnote = 14
- go to 4
- end if
-3 continue
- IsArpShift = .false.
- lnote = 0
-4 continue
- if (iv .eq. ivar1(iarp)) then
-c
-c Arp is in a single staff.
-c
- levbot = min(levar1(iarp),nolev)-ncm+3
- invert = abs(levar1(iarp)-nolev)+1
- else
-c
-c Arp covers >1 staff. Lower staff has to be the first, upper is current and
-c is where the symbol will be written.
-c
- levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
- invert = -levbot+4+nolev-ncm
-c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:'
-c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp),
-c *levbot,nolev,ncm
- end if
-c
-c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote
-c
- isym = mod(invert,2)+1
- ilvert = (invert+1)/2
- if (levbot .ge. 0 .and. levbot .le. 9) then
-c
-c Single digit
-c
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//chax(48+levbot)
- else
- notexq = notexq(1:lnote)//
- * chax(92)//symq(isym)//chax(48+levbot)
- end if
- lnote = lnote+10
- else
- if (.not.IsArpShift) then
- notexq = chax(92)//symq(isym)//'{'
- else
- notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{'
- end if
- lnote = lnote+10
- if (levbot .ge. -9) then
-c
-c Need two spaces for number
-c
- write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}'
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}'
- lnote = lnote+4
- end if
- end if
-c if (ilvert .le. 9) then
-c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1,
-c * soutq,lsout)
-c else
-c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
-c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout)
-c end if
-
- if (ilvert .gt. 9) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+ilvert)
- lnote = lnote+1
- end if
- if (IsArpShift) then
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- call addstr(notexq(1:lnote),lnote,soutq,lsout)
-c
-c cancel out the stored time, to permit two arps at same time!
-c
- tar(iarp) = -1.
- return
- end
- subroutine putast(elask,indxask,outq)
- character*129 outq,tag
- character*9 fmtq
- if (elask .ge. 0.) then
- if (elask.lt.0.995) then
- lp = 3
- else if (elask .lt. 9.995) then
- lp = 4
- else
- lp = 5
- end if
- write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)'
- else
- lp = 5
- fmtq = '(a2,f5.1)'
- end if
-c
-c Overwrite as follows: ...xyz*ask *lmnop... ->
-c ...xyz*ast{.nn}*lmnop...
-c ...xyz*ast{n.nn}*lmnop...
-c ...xyz*ast{nn.nn}*lmnop...
-c or for negative, ...xyz*ast{-nn.n}*lmnop...
- tag = outq(indxask+9:)
- write(outq(indxask+3:),fmtq)'t{',elask
- outq = outq(1:indxask+4+lp)//'}'//tag
- return
- end
- subroutine putcb(ivx,ip,notexq,lnote)
- common /comcb/ nbc,ibcdata(36)
- character*79 notexq
- logical btest
-c ivxip = ivx+16*ip
- do 1 ibc = 1 , nbc
-c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2
-c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
-c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2
- ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28)
- ipbc = igetbits(ibcdata(ibc),8,4)
- if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2
-1 continue
- call printl('Error in putbc, Call Dr. Don')
- stop
-2 continue
- if (btest(ibcdata(ibc),27)) then
- lnote = 8
- notexq = char(92)//'pbreath'
- else
- lnote = 9
- notexq = char(92)//'pcaesura'
- end if
- ivshft = igetbits(ibcdata(ibc),6,13)
-c?? ivshft = igetbits(ibcdata(ibc),6,13)-32
- if (ivshft .gt. 0) ivshft = ivshft-32
- if (ivshft.lt.0 .or. ivshft.gt.9) then
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (ivshft .lt. -9) then
- write(notexq(lnote+1:lnote+3),'(i3)')ivshft
- lnote = lnote+3
- else
- write(notexq(lnote+1:lnote+2),'(i2)')ivshft
- lnote = lnote+2
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//char(48+ivshft)
- lnote = lnote+1
- end if
- ihshft = igetbits(ibcdata(ibc),8,19)
- if (ihshft .eq. 0) then
- notexq = notexq(1:lnote)//'0'
- lnote = lnote+1
- else
- hshft = .1*(ihshft-128)
-c
-c -12.8<hshft<12.8
-c
- notexq = notexq(1:lnote)//'{'
- lnote = lnote+1
- if (hshft .lt. -9.95) then
- write(notexq(lnote+1:lnote+5),'(f5.1)')hshft
- lnote = lnote+5
- else if (hshft.lt.-0.05 .or. hshft.gt.9.95) then
- write(notexq(lnote+1:lnote+4),'(f4.1)')hshft
- lnote = lnote+4
- else
- write(notexq(lnote+1:lnote+3),'(f3.1)')hshft
- lnote = lnote+3
- end if
- notexq = notexq(1:lnote)//'}'
- lnote = lnote+1
- end if
- return
- end
- subroutine putfig(ivx,ifig,offnsk,figcheck,soutq,lsout)
- parameter (nm=24)
- common /comfig/ itfig(2,74),figqq(2,74),ivupfig(2,74),nfigs(2),
- * fullsize(nm),ivxfig2
- character*10 figqq,figq
- character*80 soutq,notexq
- character*1 ch1q,ch2q,sq,chax
- character*5 nofq,nofaq
- character*4 Figutq,Conttq
- logical figcheck
- if (ivx .eq. 1) then
- Figutq = 'Figu'
- Conttq = 'Cont'
- else
- Figutq = 'Figt'
- Conttq = 'Cott'
- end if
- sq = chax(92)
- if (abs(offnsk) .gt. .0001) then
-c
-c Write offset for floating figure, to two decimal places
-c
- notexq = sq//'off{'
- if (-offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')-offnsk
- lnote = 11
- else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')-offnsk
- lnote = 10
- else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')-offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')-offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- figq = figqq(ivx,ifig)
- ic = 1
-c nof = 0
-c nofa = -1
- nof = -ivupfig(ivx,ifig)
- nofa = -ivupfig(ivx,ifig)-1
-c
-c Beginning of manual loop
-c
-1 ch1q = figq(ic:ic)
-c
-c Exit when first blank is encountered
-c
- if (ch1q .eq. ' ') go to 2
-c
-c Starting a level. Set up vertical offset.
-c
-c lnof = 1
-c nofq = chax(nof+48)
-c if (nof .gt. 9) then
-c lnof = 2
-c nofq = '1'//chax(nof-10+48)
-c end if
-c if (nofa .eq.-1) then
-c lnofa = 2
-c nofaq = '-1'
-c else if (nofa .lt. 10) then
-c lnofa = 1
-c nofaq = chax(nofa+48)
-c else
-c lnofa = 2
-c nofaq = '1'//chax(nofa+38)
-c end if
- call istring(nof,nofq,lnof)
- call istring(nofa,nofaq,lnofa)
- if (ch1q .eq. '0') then
-c
-c Continuation figure. Next number is length (in noteskips). The number will
-c end at the first blank or char that is not digit or decimal point. If
-c colon, it is a separator and must be skipped
-c
- icnum = ic+1
-3 continue
- ic = ic+1
- if (index('0123456789.',figq(ic:ic)) .gt. 0) go to 3
- lnum = ic-icnum
- call addstr(sq//Conttq//nofq(1:lnof)//'{'
- * //figq(icnum:ic-1)//'}',7+ic-icnum+lnof,soutq,lsout)
- if (figq(ic:ic) .ne. ':') ic=ic-1
- else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then
- ic = ic+1
- ch2q = figq(ic:ic)
- if (ch2q .eq. ' ') then
-c
-c Figure is a stand-alone accidental, so must be centered
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'sharpfig}',16+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'flatfig}',15+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//nofaq(1:lnofa)//
- * '{'//sq//'natfig}',14+lnofa,soutq,lsout)
- end if
- go to 2
- else
-c
-c Figure is an accidental followed by a number
-c First put the accidental (offset to the left)
-c
- if (ch1q .eq. '#') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmsh}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. '-') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmfl}',
- * 13+lnofa,soutq,lsout)
- else if (ch1q .eq. 'n') then
- call addstr(sq//Figutq//
- * nofaq(1:lnofa)//'{'//sq//'fsmna}',
- * 13+lnofa,soutq,lsout)
- end if
-c
-c Now put the number
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch2q//'}',
- * 8+lnof,soutq,lsout)
- endif
- else if (ch1q .eq. '_') then
-c
-c Placeholder only (for lowering a figure). Don't do anything!
-c
- continue
- else
-c
-c Figure is a single number, maybe with s after
-c
- call addstr(sq//Figutq//nofq(1:lnof)//'{',
- * 6+lnof,soutq,lsout)
- ch2q = figq(ic+1:ic+1)
- if (ch2q .eq. 's') then
-c
-c Use a special character. Insert font call
-c
- ic = ic+1
- call addstr(sq//'ligfont',8,soutq,lsout)
- end if
- call addstr(ch1q//'}',2,soutq,lsout)
-c call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}',
-c * 8+lnof,soutq,lsout)
- end if
- if (ic .ge. 10) go to 2
- ic = ic+1
- nof = nof+4
- nofa = nofa+4
- go to 1
-2 continue
- if (abs(offnsk) .gt. .0001) then
- notexq = sq//'off{'
- if (offnsk .lt. -9.995) then
- write(notexq(6:11),'(f6.2)')offnsk
- lnote = 11
- else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then
- write(notexq(6:10),'(f5.2)')offnsk
- lnote = 10
- else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then
- write(notexq(6:9),'(f4.2)')offnsk
- lnote = 9
- else
- write(notexq(6:8),'(f3.2)')offnsk
- lnote = 8
- end if
- notexq = notexq(1:lnote)//sq//'noteskip}'
- call addstr(notexq,lnote+10,soutq,lsout)
- end if
- if (ifig .lt. nfigs(ivx)) then
- ifig = ifig+1
- else
- nfigs(ivx) = 0
- figcheck = .false.
- end if
- return
- end
- subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
- * ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt,
- * beamon,iscrd)
-c
-c All args are individual array element *values* except nornb,ihornb,ulq.
-c notcrd = .true. if ornament is on main note.
-c nolevm is level of main note (for chords)
-c
- parameter (nm=24)
- character*1 ulpzq,ulq(nm,9),udqq,sq,chax
- character*8 noteq
- character*79 notexq,outq
- integer*4 ihornb(nm,24),nornb(nm)
- logical btest,iscrd,usehornb,beamon
- 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
- sq = chax(92)
- lout = 0
- usehornb = .false.
- if (nodur .lt. 64) then
- stemlen = stemlin
- else
- stemlen = 0.
- end if
-c
-c Get up-downness. ulpzq is opposite from stem direction for both beams and
-c non beams. Can use in name of ornament [ . or _ ]
-c
- if (beamon) then
- if (ulq(ivx,ibmcnt) .eq. 'u') then
- ulpzq = 'l'
- else
- ulpzq = 'u'
- end if
- else
- if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then
- ulpzq = 'u'
- else
- ulpzq = 'l'
- end if
- end if
-c
-c To enable >1 ornament on a note, next line is top of manual loop.
-c
-2 continue
-c
-c Bit # of last ornament (last of bits 0-21)
-cc Bit # of last ornament (last of bits 0-24)
- ibit = log2(iand(iornq,4194303))
-c ibit = log2(iand(iornq,33554431))
- iornt = 2**ibit
-c
-c Begin routine to set height. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c 19-20: >^, 21: ? (with or w/o 16-18)
-c
-c Do not use beam height for . or _
-c
- if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then
-c
-c Height is set by special beam stuff.
-c Do not leave ihorn set, do separately for every ornament
-c
- ihorn = ihornb(ivx,nornb(ivx))
- if (ulpzq .eq. 'u') ihorn = ihorn-2
-c
-c Following flag tells whether to increment nornb when exiting the subroutine.
-c
- usehornb = .true.
- else if (ibit .eq. 14) then
-c
-c Down fermata. Don't worry about upper chord notes.
-c
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev,ncm-3)
- else
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (btest(iornt,13) .or. btest(iornt,0)) then
-c
-c ( or )
-c
- ihorn = nolev
- else if (iand(iornt,6144) .gt. 0) then
-c
-cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info
-c NOTE: removed .&_ from special beam treatment.
-c Staccato . or tenuto _ Need up-down info
-c
- if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or.
- * (minlev.ne.nolev.and.ulpzq.eq.'u')) then
- ihorn = nolev
- else if (maxlev .eq. nolev) then
- ulpzq = 'u'
- ihorn = max(nolev+stemlen,ncm+3.)
- else
- ulpzq = 'l'
- ihorn = min(nolev-stemlen,ncm-3.)
- end if
- else if (iscrd .and. nolev .eq. minlev) then
- if (ulpzq .eq. 'l') then
- ihorn = min(nolev-3,ncm-6)
- else
- ihorn = min(nolev-nint(stemlen)-3,ncm-6)
- end if
- else if (ibit.eq.10 .and. nolev.gt.90) then
-c
-c Special treatment for fermata on a shifted rest
-c
- ihorn = ncm+5
- else if (ulpzq.eq.'l') then
-c
-c (iscrd and nolev=maxlev) or (.not.iscrd)
-c
- ihorn = max(nolev+stemlen+2,ncm+5.)
- else
- ihorn = max(nolev+2,ncm+5)
- end if
- ioff = 0
- iclracc = 0
-c
-c Begin routine to set name. Bits 0-13: (stmgx+Tupf._)
-c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n
-c
- if (btest(iornt,2)) then
- notexq = sq//'shake'
- lnote = 6
- else if (btest(iornt,3)) then
- notexq = sq//'mordent'
- lnote = 8
- else if (btest(iornt,1)) then
- notexq = sq//'mtr'
- lnote = 4
- else if (btest(iornt,5)) then
- notexq = sq//'xtr'
- lnote = 4
- else if (btest(iornt,6)) then
- notexq = sq//'ptr'
- lnote = 4
- else if (btest(iornt,13)) then
- notexq = sq//'rpn'
- lnote = 4
- else if (btest(iornt,0)) then
- notexq = sq//'lpn'
- lnote = 4
- else if (btest(iornt,12)) then
- notexq = sq//ulpzq//'st'
- lnote = 4
- else if (btest(iornt,11)) then
- notexq = sq//ulpzq//'pz'
- lnote = 4
- else if (btest(iornt,8)) then
- notexq = sq//'upz'
- lnote = 4
- ioff = -2
- else if (btest(iornt,9)) then
- notexq = sq//'uppz'
- lnote = 5
- ioff = -2
- else if (btest(iornt,10)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermataup'
- else
- notexq = sq//'Fermataup'
- end if
- lnote = 10
- ioff = -2
- else if (btest(iornt,14)) then
- if (nodur .lt. 48) then
- notexq = sq//'fermatadown'
- else
- notexq = sq//'Fermatadown'
- end if
- lnote = 12
- else if (btest(iornt,21)) then
-c
-c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21
-c
- if (btest(iornq,16)) then
- notexq = sq//'qsharp'
- lnote = 7
- ioff = 2
- iornq = ibclr(iornq,16)
- iclracc = 16
- else if (btest(iornq,17)) then
- notexq = sq//'qflat'
- lnote = 6
- ioff = 1
- iornq = ibclr(iornq,17)
- iclracc = 17
- else if (btest(iornq,18)) then
- notexq = sq//'qnat'
- lnote = 5
- ioff = 2
- iornq = ibclr(iornq,18)
- iclracc = 18
- else
- notexq = sq//'qedit'
- lnote = 6
- ioff = 0
- end if
- else if (btest(iornt,16)) then
- notexq = sq//'esharp'
- lnote = 7
- ioff = 2
- else if (btest(iornt,17)) then
- notexq = sq//'eflat'
- lnote = 6
- ioff = 1
- else if (btest(iornt,18)) then
- notexq = sq//'enat'
- lnote = 5
- ioff = 2
- else if (btest(iornt,19)) then
- notexq = sq//'usf'
- lnote = 4
- ioff = -2
- else if (btest(iornt,20)) then
- notexq = sq//'usfz'
- lnote = 5
- ioff = -2
- end if
- iudorn = 0
-c
-c User-defined level shift of ornament from default?
-c
- if (btest(iornq,25)) then
-c
-c Find which (if any) element of kudorn has the shift.
-c
- do 3 iudorn = 1 , nudorn
- if (ibit .lt. 21) then
- ibitt = ibit
-c
-c Could have oes, but not oe? or oes?
-c
- else if (iclracc .gt. 0) then
-c
-c Earlier cleared edit. accid, meaning it was oes?
-c
- ibitt = iclracc+6
- else
- ibitt = 21
- end if
- ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19)
-c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4
- if (ibitt .eq. iand(33554431,kudorn(iudorn))
- * .and. ivx.eq.ivxudorn(iudorn)) go to 4
-3 continue
-c
-c Nothing shifted on this note; exit this if block
-c
- iudorn = 0
- go to 5
-4 continue
- ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32
- if (ibit.eq.19 .and. ioffinc .lt. -7) then
-c
-c Convert usf to lsf. The reason has to do with positioning being impossile
-c for some mysterious reason when you drop \usf below the staff
-c
- notexq = sq//'lsf'
- ioffinc = ioffinc+6
- end if
- ioff = ioff+ioffinc
- end if
-5 continue
-c
-c Shift level to avoid slur. Conditions are
-c 1. There is a slur
-c 2. No user-defined orn height shift (btest(iornq,25))
-c 3. upslur (islhgt>0)
-c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737
-c 5. islhgt+3 >= height already computed.
-c
- if (.not.btest(iornq,25) .and.
- * islhgt.gt.0 .and. iand(iornt,30737).eq.0)
- * ioff = ioff+dim(islhgt+3,ihorn )
- call notefq(noteq,lnoten,ihorn+ioff,ncm)
- if (lnoten.eq.1) call addblank(noteq,lnoten)
- if (iand(iornt,32896) .gt. 0) then
-c
-c T-trill or trill w/o "tr"
-c
- call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote)
- else
- notexq = notexq(1:lnote)//noteq(1:lnoten)
- lnote = lnote+lnoten
- end if
- if (iudorn .gt. 0) then
- if (btest(kudorn(iudorn),31)) then
-c
-c Horizontal shift
-c
- lform = lfmt1(ornhshft(iudorn))
- write(noteq(1:lform),'(f'//chax(48+lform)//'.1)')
- * ornhshft(iudorn)
- notexq = sq//'roffset{'//noteq(1:lform)//'}{'
- * //notexq(1:lnote)//'}'
- lnote = lnote+lform+12
- ornhshft(iudorn) = 0.
- kudorn(iudorn) = ibclr(kudorn(iudorn),31)
- end if
- end if
-c
-c Zero out the bit for ornament just dealt with.
-c
- iornq = ibclr(iornq,ibit)
- if (lout .eq. 0) then
- outq = notexq(1:lnote)
- else
- outq = outq(1:lout)//notexq(1:lnote)
- end if
- lout = lout+lnote
-c
-c Check bits 0-21, go back if any are still set
-c
- if (iand(iornq,4194303) .gt. 0) go to 2
- if (usehornb) nornb(ivx) = nornb(ivx)+1
- return
- end
- subroutine putshft(ivx,onoff,soutq,lsout)
- parameter (nm=24)
- common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
- character*80 soutq,notexq
- character*1 sq,chax
- logical onoff
- sq = chax(92)
-c
-c Start user-defined offsets X(...): or X(...)S
-c
- if (onoff) nudoff(ivx) = nudoff(ivx)+1
-c
-c Xoff is in pts. Round off to nearest .1. Will use at end of shift.
-c
- xoff = udoff(ivx,nudoff(ivx))
- xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff)
- if (.not.onoff) xoff = -xoff
- if (xoff .lt. -9.95) then
- ifmt = 5
- else if (xoff.lt.-.95 .or. xoff.gt.9.95) then
- ifmt = 4
- else
- ifmt = 3
- end if
- write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff
- call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt,
- * soutq,lsout)
- return
- end
- subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc,
- * etacs1,nv,vshrink,sepsymq)
-c
-c Called once per page, at top of page! If vshrink, only called for p.1.
-c Actual titles only allowed on p.1. (set by headlog).
-c 3/18/01: The above comment is probably bogus...can use Tt on later pages.
-c
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
- * inhead
- common /cominbot/ inbothd
- character*127 notexq
- character*120 instrq,titleq,compoq
- parameter (nm=24)
- character*1 sq,sepsymq(nm),chax
- logical headlog,vshrink
- notexq = sq//'znotes'
- lenline = 7
- do 22 iv = 1 , nv-1
- notexq = notexq(1:lenline)//sepsymq(iv)
- lenline = lenline+1
-22 continue
- notexq = notexq(1:lenline)//sq//'zcharnote{'
- lenline = lenline+11
- if (.not.headlog) then
- inhead = inhnoh
- end if
- if (vshrink .and. usevshrink) then
- inhead = 16
- end if
- ndig = int(alog10(inhead+.01))+1
- write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)//
- * ',a10)')inhead,'}{'//sq//'titles{'
- lenline = lenline+ndig+10
-c
-c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether
-c headers are present or not.
-c
- glueil = xnsttop/etatop
- vskil = etatop*glueil
- if (vshrink .and. usevshrink) vskil = 2
- call writflot(vskil,notexq,lenline)
- if (.not.headlog) then
- if (islast) write(11,'(a)')notexq(1:lenline)
- * //'}{}{0}{}{0}{}{0}}'//sq//'en%'
- else
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- lcq = lenstr(instrq,120)
- if (lcq .gt. 0) then
- xitil = etait*glueil
- if (vshrink .and. usevshrink) xitil = 2
- notexq = notexq(1:lenline)//instrq(1:lcq)//'}{'
-c
-c Null out instrument once used
-c
- instrq = ' '
- lenline = lenline+lcq+2
- call writflot(xitil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}%'
- notexq = '{'
- lenline = 1
- lcq = lenstr(titleq,120)
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//titleq(1:lcq)
- lenline = lenline+lcq
- else
- call printl(' ')
- call printl('WARNING')
- call printl(
- * ' In a title block, you have specified instrument and/or')
- call printl(
- * ' composer but no title for the piece.')
- end if
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- xtcil = etatc*glueil
- lcq = lenstr(compoq,120)
- if (lcq .eq. 0) xtcil = 2*xtcil
- if (vshrink .and. usevshrink) xtcil = 2
- call writflot(xtcil,notexq,lenline)
- notexq = notexq(1:lenline)//'}{'
- lenline = lenline+2
- if (lcq .gt. 0) then
- notexq = notexq(1:lenline)//compoq(1:lcq)//'}{'
- lenline = lenline+2+lcq
-c
-c Null out compoq so it does not get written later
-c
- compoq = ' '
- xcsil = etacs1*glueil
- if (vshrink .and. usevshrink) xcsil = 2
- call writflot(xcsil,notexq,lenline)
- else
- notexq = notexq(1:lenline)//'}{0'
- lenline = lenline+3
- end if
- if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%'
- headlog = .false.
- end if
- return
- end
- subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom,
- * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum,
- * eloff,iup,irest,usexnumt)
-c
-c Places digit for xtuplet.
-c
- character*1 chax
- character*8 noteq
- character*79 notexq
- logical btest,usexnumt
- if (iflop.ne.0 .and. multb.gt.0) then
-c
-c Number goes on beam side, move R/L by .5 wheadpt for upper/lower
-c
- eloff = eloff-0.5*iud*wheadpt/poenom
-c
-c Number goes on beam side, must use beam parameters to set pos'n
-c
- nlnum = nolev1+islope/slfac*eloff+iup*(multb+8)
- if (multb .ge. 2) nlnum = nlnum+iup
- else
- nlnum = nint(xnlmid-1+3*iud+iflop*11)
- end if
- if (.not.btest(islur,31)) then
-c
-c Only print number when wanted. First check vert, horiz offset
-c
- if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16
- if (btest(irest,7)) eloff = eloff+
- * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom
- if (.not.usexnumt) then
- notexq = chax(92)//'xnum{'
- lnote = 10
- istrtn = 7
- else
- notexq = chax(92)//'xnumt{'
- lnote = 11
- istrtn = 8
- end if
- if (eloff .lt. 0.995) then
- write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff
- else if (eloff .lt. 9.995) then
- write(notexq(istrtn:istrtn+3),'(f4.2)')eloff
- else
- write(notexq(istrtn:istrtn+4),'(f5.2)')eloff
- lnote = lnote+1
- end if
- call notefq(noteq,lnoten,nlnum,ncmid)
- notexq = notexq(1:lnote)//'}'//noteq(1:lnoten)
- lnote = lnote+1+lnoten
- if (ntupv .lt. 10) then
- write(notexq(lnote+1:lnote+1),'(i1)')ntupv
- lnote = lnote+1
- else
- notexq = notexq(1:lnote)//'{'
- write(notexq(lnote+2:lnote+3),'(i2)')ntupv
- notexq = notexq(1:lnote+3)//'}'
- lnote = lnote+4
- end if
- end if
- return
- end
- subroutine read10(string,lastchar)
- parameter (maxblks=4000)
- character*65536 bufq
- integer*2 lbuf(maxblks)
- common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
- character*(*) string
- character*128 lnholdq
- logical lastchar
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
- if (.not.mplay) then
- if (ilbuf .gt. nlbuf) go to 999
- call getbuf(string)
- return
-999 lastchar = .true.
- return
- else
-c
-c Play a macro. Set pointer to first character needed in buffer
-c
- if (ilmac .eq. il1mac(macnum)) then
-c
-c Getting first line of macro
-c
- ip1 = ip1mac(macnum)
- iplmac = ip1-ic1mac(macnum)
- else if (ilmac .le. il2mac(macnum)) then
-c
-c Beyond first line of macro. Advance line-start pointer.
-c
- iplmac = iplmac+lbuf(ilmac-1)
- ip1 = iplmac+1
- else
-c
-c Beyond last line of macro. Terminate it!
-c
- mplay = .false.
- endmac = .true.
- return
- end if
- if (ilmac .eq. il2mac(macnum)) then
-c
-c Getting last line of macro.
-c
- ip2 = ip2mac(macnum)
- else
-c
-c Getting line before last line of macro.
-c
- ip2 = iplmac+lbuf(ilmac)
- end if
- if (ip2 .ge. ip1) then
- string = bufq(ip1:ip2)
- else
-c
-c Kluge for when macro start is on a line by itself
-c
- string = ' '
- end if
- ilmac = ilmac+1
- return
- end if
- end
- function readin(lineq,iccount,nline)
-c
-c Reads a piece of setup data from file lineq, gets a new lineq from
-c file 10 (jobname.pmx) and increments nline if needed, passes over
-c comment lines
-c
- character*128 lineq
- character*1 durq,chax
-4 if (iccount .eq. 128) then
-1 call getbuf(lineq)
- nline = nline+1
- if (lineq(1:1) .eq. '%') go to 1
- iccount = 0
- end if
- iccount = iccount+1
-c
-c Find next non-blank or end of line
-c
- do 2 iccount = iccount , 127
- if (lineq(iccount:iccount) .ne. ' ') go to 3
-2 continue
-c
-c If here, need to get a new line
-c
- iccount = 128
- go to 4
-3 continue
-c
-c iccount now points to start of number to read
-c
- i1 = iccount
-5 call getchar(lineq,iccount,durq)
-c
-c Remember that getchar increments iccount, then reads a character.
-c
- if (index('0123456789.-',durq) .gt. 0) go to 5
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin
- return
- end
- subroutine readmeter(lineq,iccount,mtrnum,mtrden)
- character*128 lineq
- character*1 durq,chax
- if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then
-c
-c No slashes, so use old method
-c
- call getchar(lineq,iccount,durq)
- if (durq .eq. '-') then
-c
-c Negative numerator is used only to printed; signals vertical slash
-c
- call getchar(lineq,iccount,durq)
- mtrnum = -(ichar(durq)-48)
- else if (durq .eq. 'o') then
-c
-c Numerator is EXACTLY 1
-c
- mtrnum = 1
- else
- mtrnum = ichar(durq)-48
- if (mtrnum .eq. 1) then
-c
-c Numerator is >9
-c
- call getchar(lineq,iccount,durq)
- mtrnum = 10+ichar(durq)-48
- end if
- end if
- call getchar(lineq,iccount,durq)
- if (durq .eq. 'o') then
- mtrden = 1
- else
- mtrden = ichar(durq)-48
- if (mtrden .eq. 1) then
- call getchar(lineq,iccount,durq)
- mtrden = 10+ichar(durq)-48
- end if
- end if
- else
-c
-c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm'
-c
- iccount = iccount+1
- ns = index(lineq(iccount:128),'/')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum
-c
-c Reset iccount to start of second integer
-c
- iccount = iccount+ns
-c
-c There must be either a slash or a blank at pos'n 2 or 3
-c
- ns = index(lineq(iccount:iccount+2),'/')
- if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ')
- read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden
-c
-c Set iccount to last character used
-c
- iccount = iccount+ns-1
- end if
- return
- end
- subroutine readnum(lineq,iccount,durq,fnum)
-c
-c This reads a number starting at position iccount. Remember that on exit,
-c getchar leaves iccount at the last character retrieved. So must only
-c call this routine *after* detecting a number or decimal.
-c On exit, durq is next character after end of number.
-c
- character*128 lineq
- character*1 durq,chax
- i1 = iccount
-1 call getchar(lineq,iccount,durq)
- if (index('0123456789.',durq) .gt. 0) go to 1
- i2 = iccount-1
- if (i2 .lt. i1) then
- print*,'Found "'//durq//'" instead of number'
- call stop1()
- else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then
- i2 = i2-1
- iccount = iccount-1
- end if
- icf = i2-i1+49
- read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum
- return
- end
- subroutine setbits(isdata,iwidbit,ishift,ivalue)
-c
-c Sets iwidbits of isdata, shifted by ishift, to ivalue
-c
- ibase = 2**iwidbit-1
- if (ivalue.gt.ibase) then
- print*
- print*,'WARNING in setbits: ivalue > ibase'
- write(15,'(/,a)')'WARNING in setbits: ivalue > ibase'
- end if
- isdata = iand(not(ishft(ibase,ishift)),isdata)
- isdata = ior(isdata,ishft(ivalue,ishift))
- return
- end
- subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
-c
-c The MEAN SQUARE slope algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,
- * isfig
- real*4 xelsk(24)
- integer ipb(24)
- ibc = ibmcnt(ivx)
- sumxx = 0.
- sumxy = 0.
- do 2 inb = 1 , nnb
- sumxx = sumxx+xelsk(inb)**2
- sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb))
-2 continue
- delta = nnb*sumxx-sumx*sumx
- em = (nnb*sumxy-sumx*sumy)/delta
- islope = nint(0.5*em*slfac)
- if (iabs(islope) .gt. 9) islope = isign(9,islope)
- beta = (sumy-islope/slfac*sumx)/nnb
- nolev1 = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- do 4 inb = 1 , nnb
- ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
- ynote = nolev(ivx,ipb(inb))
- smin = min(smin,iul*(ybeam-ynote))
-4 continue
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolev1 = nint(nolev1+iul*deficit)
- end if
- return
- end
- subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,
- * ivx,nline)
- character*1 charq,durq
- common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
- logical mrecord,mplay,endmac,btest
- character*128 lnholdq,lineq
- common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
- * ic1mac(20),ilmac,iplmac
-c
-c Macro action
-c
- call g1etchar(lineq,iccount,charq)
- if (charq.eq.'S' .and. ivx.ne.1) then
- print*
- print*
- print*,'*********WARNING*********'
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * '"MS..." only put in parts by scor2prt if in voice #1!')
- end if
- if (index('RSP ',charq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Illegal character after "M" (macro)!')
- call stop1()
- else if (charq .ne. ' ') then
-c
-c Record or playback a macro. Get the number of the macro.
-c
- call g1etchar(lineq,iccount,durq)
- if (index('123456789',durq) .eq. 0) then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Must input number after "MR","MP", or "MS"!')
- call stop1()
- end if
- call readnum(lineq,iccount,durq,fnum)
- macnum = nint(fnum)
- if (durq .ne. ' ') then
- call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
- * 'Macro number must be followed by a blank!')
- call stop1()
- end if
- if (index('RS',charq ).gt. 0) then
-c
-c Record or save a macro
-c
- if (macnum.lt.1 .or. macnum.gt.20) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Macro number not in range 1-20!')
- call stop1()
-c else if (btest(macuse,macnum)) then
-c print*
-c print*,'WARNING: Redefining macro # ',macnum
- end if
- macuse = ibset(macuse,macnum)
- if (charq .eq. 'R') then
- call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- else if (charq .eq. 'S') then
-c
-c Save (Record but don't activate)
-c
-1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
- if (mrecord) then
- call getbuf(lineq)
- nline = nline+1
- iccount = 0
- go to 1
- end if
- iccount = iccount+ndxm+1
- end if
- else
-c
-c Playback the macro
-c
- if (.not.btest(macuse,macnum)) then
- call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
- * 'Cannot play a macro that has not been recorded!')
- call stop1()
- end if
- icchold = iccount
- lnholdq = lineq
- iccount = 128
- mplay = .true.
- ilmac = il1mac(macnum)
- end if
- end if
- return
- end
- subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
-c
-c Sets last 2 args depending on 1st 2, (logical) num, denom.
-c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings.
-c 1: all duple meters
-c 2: triple w/ denom=4, subdivide in groups of 2 8ths
-c 3: triple w/ denom=8, subdivide in groups of 3 8ths
-c Note that lenbar is set at top or when 'm' symbol is read in getnote
-c
- if (mtrdenl .eq. 4) then
- if (mod(mtrnuml,3) .eq. 0) then
- ibmtyp = 2
- ibmrep = mtrnuml/3
- else
- ibmtyp = 1
- ibmrep = mtrnuml/2
- end if
- else if (mtrdenl .eq. 2) then
- ibmtyp = 1
- if (mtrnuml .eq. 3) then
- ibmrep = 3
- else
- ibmrep = 2*mtrnuml/mtrdenl
- end if
- else
-c
-c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8
-c
- ibmtyp = 3
- ibmrep = mtrnuml/3
- end if
-c
-c Reset so we don't keep writing new meters
-c
- mtrnuml = 0
-c
-c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter
-c
- ibmrep = max(ibmrep,1)
- return
- end
- subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest)
-c
-c The outer combo algorithm
-c
- parameter (nm=24)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- common /comipl2/ ipl2(nm,200)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,btest,
- * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm
- common /comeskz2/ eskz2(nm,200)
- real*4 slope(800),xelsk(24)
- integer ipb(24)
- common /comask/ bar1syst,fixednew,scaldold,
- * wheadpt,fbar,poenom
- common /comas1/ naskb,task(40),wask(40),elask(40)
- common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm),
- * mtupv(nm,9),nxtinbm(nm),
- * islope(nm),xels11(24),eloff(nm,9),
- * nssb(nm),issb(nm),lev1ssb(nm,20)
- common /comdraw/ drawbm(nm)
- common /combmh/ bmhgt,clefend
- common /commvl/ nvmx(nm),ivmx(nm,2),ivx
- common /comtol/ tol
- ibc = ibmcnt(ivx)
- nxtinbm(ivx) = 0
- n1 = ipl2(ivx,ibm1(ivx,ibc))
-c
-c Initialize counters used in this subroutine, and then later during actual
-c beam drawing, to count later segments of single-slope beam groups
-c
- nssb(ivx) = 0
- issb(ivx) = 0
-c
-c Set flag for xtup beam starting with rest (no others can start with rest)
-c
- if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1
-c
-c Figure how many elemskips to each note. Use the list, counting only non-rests.
-c
- eskz0 = eskz(ivx,ibm1(ivx,ibc))
- nnb = 0
- sumx = 0.
- sumy = 0.
- ipxt1 = 0
- iplast = ibm2(ivx,ibc)
- do 2 ip = ibm1(ivx,ibc) , iplast
- if (.not.btest(irest(ivx,ip),0)) then
- nnb = nnb+1
- ipb(nnb) = ip
- xelsk(nnb) = eskz(ivx,ip)-eskz0
- sumx = sumx+xelsk(nnb)
- sumy = sumy+nolev(ivx,ipb(nnb))
- if (btest(nacc(ivx,ip),21)) then
-c
-c This is the starting note of later segment of single-slope beam group
-c Temporarily store ip here.
-c
- nssb(ivx) = nssb(ivx)+1
- lev1ssb(ivx,nssb(ivx)) = nnb
- end if
- end if
-c
-c New xtup stuff here. Final object is to get distance from start of xtup
-c to number. xtinbm counts xtups in this beam only. mtupv is the printed
-c number. ntupv is number of notes in xtup, and is only used to get
-c eloff, the distance from start of xtup to the number.
-c
- if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1
- if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then
-c
-c Xtup is starting here
-c
- nxtinbm(ivx) = nxtinbm(ivx)+1
- ipxt1 = ip
- if (btest(nacc(ivx,ip),18)) then
- ndoub = 1
- else
- ndoub = 0
- end if
- else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then
-c
-c Xtup ends here. Set total number of notes in xtup.
-c
- ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1
-c
-c Set printed number for embedded xtup.
-c
- mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub
-c
-c Middle note of xtup if ntupv odd, note to left of gap if even.
-c
- ipxtmid = (ip+ipxt1)/2
- eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1)
- if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0)
- * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+
- * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid))
- ipxt1 = 0
- end if
-2 continue
-c
-c Reset nxtinbm for use as counter as #'s are posted by putxtn(..)
-c
- nxtinbm(ivx) = 0
- smed = 0.
- if (.not.btest(islur(ivx,ipb(1)),2)) then
-c
-c No forced 0 slope
-c
- if (nnb .eq. 1) go to 6
- nsc = 0
- do 5 inb = 1 , nnb-1
- do 5 jnb = inb+1 , nnb
- nsc = nsc+1
- slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/
- * (xelsk(jnb)-xelsk(inb))
- if (abs(slope(nsc)) .lt. 1.e-4) then
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- nsc = nsc+1
- slope(nsc) = slope(nsc-1)
- end if
-5 continue
- if (nsc .eq. 1) then
- smed = slope(1)
- go to 6
- end if
- nscmid = nsc/2+1
- do 7 i = 1 , nscmid
- do 7 j = i+1 , nsc
- if (slope(j) .lt. slope(i)) then
- t = slope(j)
- slope(j) = slope(i)
- slope(i) = t
- end if
-7 continue
- smed = slope(nscmid)
- if (nsc .eq. 2*(nsc/2)) then
-c
-c Even number of slopes in the list, so median is ambiguous
-c
- if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then
-c
-c Lower-numbered one is truly less in absolute value, so use it
-c
- smed=slope(nscmid-1)
- else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then
-c
-c Two slopes are effectively equal. Take the one with sign of the average
-c
- sum = 0.
- do 1 i = 1 , nsc
- sum = sum+slope(i)
-1 continue
- smed = sign(smed,sum)
- end if
- end if
-6 continue
- islope(ivx) = nint(0.5*smed*slfac)
- if (iabs(islope(ivx)) .gt. 9)
- * islope(ivx) = isign(9,islope(ivx))
- else
-c
-c Forced horizontal beam
-c
- islope(ivx) = 0
- end if
- beta = (sumy-islope(ivx)/slfac*sumx)/nnb
-c
-c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use
-c as is for placing xtup number and/or bracket, then reset it for start of
-c actual beam
-c
- nolev1(ivx) = nint(beta)
-c
-c Check if any stems are too short
-c
- smin = 100.
- iul = -1
- if (ulq(ivx,ibc) .eq. 'u') iul = 1
- ssq = 0.
- syb = 0.
-c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1))
- yb1 = nolev1(ivx)
- * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1))
- do 4 inb = 1 , nnb
- ybeam = yb1+islope(ivx)*xelsk(inb)/slfac
-c * -iul*bmhgt*(mult(ivx,ipb(inb))-1)
- * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1)
- syb = syb+ybeam
- ynote = nolev(ivx,ipb(inb))
- off = ybeam-ynote
- if (inb .eq. 1) then
- off1 = off
- else if (inb .eq. nnb) then
- off2 = off
- end if
- ssq = ssq+off*off
- smin = min(smin,iul*off)
-4 continue
- dnolev = 0.
- if (smin .lt. stemmin) then
- deficit = stemmin-smin
- nolevo = nolev1(ivx)
- nolev1(ivx) = nint(nolev1(ivx)+iul*deficit)
- dnolev = nolev1(ivx)-nolevo
- off1 = off1+dnolev
- off2 = off2+dnolev
- end if
- ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
- if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and.
- * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)
- * .and. .not.btest(islur(ivx,ipb(1)),2)) then
-c
-c The first check is to save trouble of putting xtup's in setbm2.
-c The penultimate check is that first and last stems aren't both excessive.
-c The last check is that a 0 slope has not been forced
-c
- call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx))
- end if
-c
-c Check if beam starts or ends too high or low.
-c
-c xboff = bmhgt*(mult(ivx,ipb(1))-1)
- xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)
- l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0.
- xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb)
- l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0
- if (l1ng .or. l2ng) then
-c
-c Need to correct start or stop, also slope
-c
- if (l1ng) then
- nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul)
- end if
- if (l2ng) then
- xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul)
- end if
-c
-c Since one or the other end has changed, need to change slope
-c
- if (.not.btest(islur(ivx,ipb(1)),2))
- * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb))
- end if
- if (nssb(ivx) .gt. 0) then
-c
-c This is a single-slope beam group. Store start heights for later segs.
-c
- do 3 issbs = 1 , nssb(ivx)
- lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac*
- * xelsk(lev1ssb(ivx,issbs))
-3 continue
- end if
- return
- end
- subroutine sortpoe(nsyst,poe,ipoe)
- parameter (nks=125)
- real*4 poe(nks)
- integer*4 ipoe(nks)
-c
-c Initialize ipoe:
-c
- do 3 iord = 1 , nsyst
- ipoe(iord) = iord
-3 continue
-c
-c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will
-c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe.
-c
- do 4 io1 = 1 , nsyst-1
- do 5 io2 = io1+1 , nsyst
- if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then
-c
-c Interchange the indices
-c
- itemp = ipoe(io1)
- ipoe(io1) = ipoe(io2)
- ipoe(io2) = itemp
- end if
-5 continue
-4 continue
- return
- end
- subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * isdat4,nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 This subr is called ONLY for postscript slurs.
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
- isdat4(nsdat) = 0
- ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur
-c
-c Get ID code
-c
- call getchar(lineq,iccount,durq)
- if (index('uldtb+-hfnHps ',durq) .gt. 0) then
-c
-c Null id. Note for ps slurs, 'H' cannot be an ID
-c
- iccount = iccount-1
- if (lineq(iccount:iccount) .eq. 't') then
- idcode = 1
- else
- idcode = 32
- end if
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- if (lineq(iccount-1:iccount-1) .eq. 't') then
-c
-c Make t[ID] look like s[ID]t
-c
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics.
-c
- if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then
-c
-c There's a default curvature tweak
-c
- icurv1 = nint(SlurCurve)+3
- if (icurv1 .eq. 2) icurv1 = 1
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- end if
-c
-c Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (durq .eq. 's') then
-c
-c Endpoint tweaks for linebreak slurs.
-c
- call getchar(lineq,iccount,durq) ! Must be +|-
-c
-c Next is vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- if (durq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32)
- if (index('+-',dumq) .gt. 0) then
-c
-c Also a horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,durq,fnum)
- if (dumq .eq. '-') fnum=-fnum
- call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64)
- end if
- iccount = iccount-1
- ilb12 = 1
- go to 1
- else if (index('fnhH',durq).gt.0) then
-c
-c Special ps slur curvatures.
-c Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = index('fnxhH',durq)
- if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- else if (durq .eq. 'p') then ! Local adjustment
- call getchar(lineq,iccount,durq) ! +|-
- call getchar(lineq,iccount,dumq) ! s|t
-c 26 \sluradjust (p+s)
-c 27 \nosluradjust (p-s)
-c 28 \tieadjust (p+t)
-c 29 \notieadjust (p-t)
- if (durq .eq. '+') then
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),26)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),28)
- end if
- else
- if (dumq .eq. 's') then
- isdat2(nsdat) = ibset(isdat2(nsdat),27)
- else
- isdat2(nsdat) = ibset(isdat2(nsdat),29)
- end if
- end if
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
- * nsdat,notcrd,nolev,starter)
- parameter (nm=24)
-c
-c Reads in slur data. Record all h/v-shifts for non-chords, user-specified
-c ones for chords.
-c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript
-c
-c See subroutine doslur for bit values in isdat1,2,3
-c
- common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24),
- * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn,
- * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2
- integer*4 isdat1(202),isdat2(202),isdat3(202)
- logical notcrd,btest
- character*128 lineq
- character*1 durq,dumq,starter
- common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur
- * ,WrotePsslurDefaults,SlurCurve
- logical upslur,fontslur,WrotePsslurDefaults
-c
-c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve
-c
- numint = 0
- ivoff = 0
- ihoff = 0
- nsdat = nsdat+1
- if (starter.eq.'{' .or. starter.eq.'}')
- * isdat2(nsdat)=ibset(isdat2(nsdat),3)
- call setbits(isdat1(nsdat),5,13,iv)
- call setbits(isdat1(nsdat),1,12,kv-1)
- call setbits(isdat1(nsdat),8,3,ip)
- isdat3(nsdat) = 0
-c
-c Get id letter
-c
- if (lineq(iccount:iccount) .eq. 't') then
-c
-c Old-style t-slur. Use special idcode = 1
-c
- idcode = 1
- else
- call getchar(lineq,iccount,durq)
- if (index('uldtb+-hf ',durq) .gt. 0) then
-c
-c Null id
-c
- idcode = 32
- iccount = iccount-1
- else if (durq.eq.'H') then
-c
-c Postscript slur, cannot use 'H' as code, must check for 2nd 'H'
-c
- idcode = 32
- iccount = iccount-1
-c
-c There may be another "H", but no need to deal with it yet
-c
- else
-c
-c Set explicit idcode
-c
- idcode = ichar(durq)
- end if
- end if
- call setbits(isdat1(nsdat),7,19,idcode)
-c
-c Set start/stop: look thru list from end for same idcode,iv,kv
-c
- do 2 isdat = nsdat-1 , 1 , -1
- if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
- * iv .eq. igetbits(isdat1(isdat),5,13) .and.
- * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
-c
-c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0.
-c
- if (btest(isdat1(isdat),11)) go to 3
-c
-c Found slur is a turnoff, so new one is a turnon. Jump down to set bit
-c
- go to 4
- end if
-2 continue
-c
-c If here, this is turnon.
-c
-4 continue
- isdat1(nsdat) = ibset(isdat1(nsdat),11)
-3 continue
-c
-c Now done with initial turnon- or turnoff-specifics. Loop for rest of input
-c
-1 call getchar(lineq,iccount,durq)
- if (index('uld',durq) .gt. 0) then
-c
-c Force direction
-c
- isdat1(nsdat) = ibset(isdat1(nsdat),26)
- if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
- go to 1
- else if (index('+-',durq) .gt. 0) then
- numint = numint+1
- if (numint .eq. 1) then
-c
-c Vertical offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
- ivoff = nint(fnum)
- if (durq .eq. '-') ivoff = -ivoff
- else if (numint .eq. 2) then
-c
-c Horizontal offset
-c
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- iccount = iccount-1
-c
-c fnum is abs(hshift), must be 0 to 6.3
-c
- ihoff = fnum*10 + .5
- if (durq .eq. '-') ihoff = -ihoff
-c
-c Later will set bits to 1...127 to represent -6.3,...+6.3
-c
- else
-c
-c Must be the 3rd signed integer, so it's a curve specification
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
- iccount = iccount+1
- call readnum(lineq,iccount,dumq,fnum)
- icurv1 = nint(fnum)
- if (durq .eq. '-') icurv1 = -icurv1
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- if (dumq .ne. ':') then
-c
-c Back up the pointer and loop for more input
-c
- iccount = iccount-1
- else
-c
-c Expect two single digits as parameters for curve
-c
- isdat3(nsdat) = ibset(isdat3(nsdat),1)
- call setbits(isdat3(nsdat),3,8,
- * ichar(lineq(iccount+1:iccount+1))-48)
- call setbits(isdat3(nsdat),3,11,
- * ichar(lineq(iccount+2:iccount+2))-48)
- iccount = iccount+2
- end if
- end if
- go to 1
- else if (durq .eq. 't') then
- isdat2(nsdat) = ibset(isdat2(nsdat),3)
- go to 1
- else if (durq .eq. 'b') then
- isdat2(nsdat) = ibset(isdat2(nsdat),4)
- go to 1
- else if (index('fhH',durq) .gt. 0) then
-c
-c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6)
-c
- icurv1 = 2+index('fhH',durq)
- if (icurv1 .eq. 3) then
- icurv1 = 1
- else if (icurv1 .eq. 5) then
-c
-c check for 2nd H
-c
- if (lineq(iccount+1:iccount+1) .eq. 'H') then
- iccount = iccount+1
- icurv1 = 6
- end if
- end if
- isdat3(nsdat) = ibset(isdat3(nsdat),0)
-c
-c Must change sign if downslur, but cannot do it now since we don't know
-c slur direction for sure.
-c
- call setbits(isdat3(nsdat),6,2,32+icurv1)
- go to 1
- end if
-c
-c Record shifts
-c
- call setbits(isdat2(nsdat),6, 6,ivoff+32)
- call setbits(isdat2(nsdat),7,12,ihoff+64)
-c
-c Record chord flag, note level, notehead shift
-c
- if (notcrd) then
- call setbits(isdat2(nsdat),7,19,nolev)
- else
- nolevc = igetbits(icrdat(ncrd),7,12)
- call setbits(isdat2(nsdat),7,19,nolevc)
- isdat2(nsdat) = ibset(isdat2(nsdat),0)
- call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
- end if
- return
- end
- subroutine stop1()
- call exit(1)
- end
- subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
- * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur)
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink,fontslur
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8),
- * xinsnow,lowdot
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- character*79 inameq
- character*44 basenameq
- character*24 fmtq
- character*5 fbarq
- character*1 clefq(nm),sq,chax
- common /comstart/ facmtr
- logical vshrink,lowdot,rename
- logical novshrinktop,cstuplet
- common /comnvst/ novshrinktop,cstuplet
- common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm),
- * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans
- logical EarlyTransOn,LaterInstTrans
- common /comsize/ isize(nm)
- sq = chax(92)
- vshrink = xinstf1.gt.20. .and. .not.novshrinktop
- if (vshrink) then
- xinsnow = 10.
- else
- xinsnow = xinstf1
- end if
- if (.not.islast) return
- write(11,'(a)')'%%%%%%%%%%%%%%%%%'
- write(11,'(a)')'%'
- write(11,'(a)')'% '//basenameq(1:lbase)//'.tex'
- write(11,'(a)')'%'
- write(11,'(a)')'%%%%%%%%%%%%%%%%'
- write(11,'(a)')sq//'input musixtex'
- write(11,'(a)')sq//'input pmx'
-c write(11,'(a)')sq//'input musixmad'
-c write(11,'(a)')sq//'input musixxad'
- write(11,'(a)')
- * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%'
- if (.not.fontslur) write(11,'(a)')sq//'input musixps'
-c
-c Need to input musixmad to permit more slurs.
-c
- if (musicsize .eq. 20) then
- write(11,'(a)')sq//'normalmusicsize%'
- else if (musicsize .eq. 16) then
- write(11,'(a)')sq//'smallmusicsize%'
- else if (musicsize .eq. 24) then
- write(11,'(a)')sq//'largemusicsize%'
- write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
- * 'meterlargefont}%'
- else if (musicsize .eq. 29) then
- write(11,'(a)')sq//'Largemusicsize%'
- write(11,'(a)')sq//'def'//sq//'meterfont{'//sq//
- * 'meterLargefont}%'
- end if
-c
-c Set sizes. Have sizes per staff in isize(.) and noinst per staff in
-c nsperi(.)
-c
- iiv = 1
- do 5 iinst = 1 , noinst
- if (isize(iiv) .eq. 1) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'smallvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'smallvalue%'
- end if
- else if (isize(iiv) .eq. 2) then
- if(iinst.le.9) then
- write(11,'(a8,i1,a)')
- * sq//'setsize',iinst,sq//'tinyvalue%'
- else
- write(11,'(a9,i2,a)')
- * sq//'setsize{',iinst,'}'//sq//'tinyvalue%'
- end if
- end if
- iiv = iiv+nsperi(iinst)
-5 continue
-c
-c do 5 iiv = 1 , nv
-c if (isize(iiv) .eq. 1) then
-c if(iiv.le.9) then
-c write(11,'(a8,i1,a)')
-c * sq//'setsize',iiv,sq//'smallvalue%'
-c else
-c write(11,'(a9,i2,a)')
-c * sq//'setsize{',iiv,'}'//sq//'smallvalue%'
-c end if
-c else if (isize(iiv) .eq. 2) then
-c if(iiv.le.9) then
-c write(11,'(a8,i1,a)')
-c * sq//'setsize',iiv,sq//'tinyvalue%'
-c else
-c write(11,'(a9,i2,a)')
-c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%'
-c end if
-c end if
-c5 continue
-c
- write(fbarq,'(f5.3)')fbar
- write(11,'(a)')sq//'nopagenumbers'
- write(11,'(a)')sq//'tracingstats=2'//sq//'relax'
- write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt'
- write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)')
- * sq//'vsize',int(height+.1),'pt'
-c
-c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if
-c 3 sharps and treble clef, to avoid vertical clash with top space g#
-c
- if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)')
- * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}'
- if (noinst .lt. 10) then
- write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- else
- write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{',
- * noinst,'}'
- end if
- iv = 0
- do 1 iinst = 1 , noinst
- nstaves = nsperi(iinst)
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setstaffs'//chax(48+iinst)
- * //chax(48+nstaves)
- else
- write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}'
- * //chax(48+nstaves)
- end if
- iv = iv+1
- if (nstaves .eq. 1) then
- fmtq = chax(48+numclef(clefq(iv)))
- lfmtq = 1
- else
- fmtq = '{'//chax(48+numclef(clefq(iv)))
- lfmtq = 2
- do 2 k = 2 , nstaves
- iv = iv+1
- fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv)))
- lfmtq = lfmtq+1
-2 continue
- fmtq = fmtq(1:lfmtq)//'}'
- lfmtq = lfmtq+1
- end if
- if (iinst .lt. 10) then
- write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq)
- else
- write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq)
- end if
- do 3 lname = 79 , 2 , -1
- if (inameq(iinst)(lname:lname) .ne. ' ') go to 4
-3 continue
-4 continue
- lnam(iinst) = lname
- if (iinst .lt. 10) then
- write(11,'(a8,i1,a)')sq//'setname',iinst,
- * '{'//inameq(iinst)(1:lname)//'}'
- else
- write(11,'(a9,i2,a)')sq//'setname{',iinst,
- * '}{'//inameq(iinst)(1:lname)//'}'
- end if
-1 continue
- write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%'
- if (EarlyTransOn)
- * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn)
- call wgmeter(mtrnmp,mtrdnp)
- ipi = nint(fracindent*widthpt)
- if (ipi .lt. 10) then
- write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
- else if (ipi .lt. 100) then
- write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
- else
- write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
- end if
- write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip'
- * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax'
- if (.not.vshrink) then
- if (xinstf1 .lt. 9.95) then
- fmtq = '(a,f3.1,a)'
- else
- fmtq = '(a,f4.1,a)'
- end if
- write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt'
- * //sq//'interstaff{',xinstf1,'}'//sq//'relax'
- else
- write(11,'(a)')sq//'stafftopmarg0pt'//
- * sq//'staffbotmarg5'//sq//'Interligne'//sq//
- * 'interstaff{10}'//sq//'relax'
- end if
- if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
- write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
- if (cstuplet) then
- write(11,'(a)')sq//'input tuplet'
- * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}'
- * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}'
- * //sq//'/'//sq//'/}}%'
- write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet'
- * //sq//'let'//sq//'unbkt'//sq//'downtuplet%'
- end if
- write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq//
- * 'addspace'//sq//'afterruleskip%'
- return
- end
- character*1 function udfq(nolev,ncm)
-c
-c Slur directions
-c
- common /combc/ bcspec
- logical bcspec
- ntest = nolev-ncm
- if (ntest.lt.0 .or.
- * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then
- udfq = 'd'
- else
- udfq = 'u'
- end if
- return
- end
- character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv)
-c
-c Stem direction for single notes
-c
- character*1 ulfq
- character*1 udqqq
- logical btest
- if (btest(isl,30)) then
-c
-c Absolute override
-c
- if (btest(isl,17)) then
- udqqq = 'u'
- else
- udqqq = 'l'
- end if
- else if (nvmx .eq. 1) then
-c
-c Single voice per staff, default
-c
- udqqq = ulfq(1.*nole,ncm)
- else
-c
-c Multi-voice per staff, 1st is lower, 2nd upper
-c
- if (ivx .le. nv) then
- udqqq = 'l'
- else
- udqqq = 'u'
- end if
- end if
- udqq = udqqq
- return
- end
- character*1 function ulfq(xnolev,ncm)
-c
-c Stem directions
-c
- common /combc/ bcspec
- logical bcspec
- test = xnolev-ncm
- if (test.lt.-.001 .or.
- * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then
- ulfq = 'u'
- else
- ulfq = 'l'
- end if
- return
- end
- function upcaseq(chq)
- character*1 chq,upcaseq,chax
- if (ichar(chq).ge.61.and.ichar(chq).lt.122) then
- upcaseq = chax(ichar(chq)-32)
- else
- upcaseq = chq
- print*,'Warning, upcaseq was called with improper argument: '
- * //chq
- stop
- end if
- return
- end
- subroutine wgmeter(mtrnmp,mtrdnp)
-c
-c Writes meter stuff to file 11, so only called if islast=.true.
-c
- character*1 sq,chax
- if (mtrdnp .eq. 0) return
- sq=chax(92)
- if (mtrnmp.gt.0 .and. mtrnmp.le.9) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i1,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .ge. 10) then
- if (mtrdnp .lt. 10) then
- write(11,'(a25,i2,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- else
- write(11,'(a25,i2,a2,i2,a3)')
- * sq//'generalmeter{'//sq//'meterfrac{',
- * mtrnmp,'}{',mtrdnp,'}}%'
- end if
- else if (mtrnmp .lt. 0) then
- write(11,'(a26,i1,a2,i1,a3)')
- * sq//'generalmeter{'//sq//'meterfracS{',
- * -mtrnmp,'}{',mtrdnp,'}}%'
- else if (mtrdnp .le. 4) then
- write(11,'(a21,i1,a2)')
- * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%'
- else if (mtrdnp .eq. 5) then
- write(11,'(a)')sq//'generalmeter'//sq//'allabreve%'
- else if (mtrdnp .eq. 6) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterC%'
- else if (mtrdnp .eq. 7) then
- write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%'
- end if
- return
- end
- subroutine writemidi(jobname,ljob)
- parameter(nm=24,mv=24576)
- common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
- * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200),
- * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm),
- * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
- * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
- * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
- * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200),
- * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
- * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9)
- character*1 ulq,sepsymq,sq
- logical beamon,firstgulp,figbass,figchk,isfig
- character*1 byteq(4),char,chax
- character*10 tempoq,instq
- character*44 jobname
- integer*2 mmidi
- logical restpend,relacc,notmain,twoline,ismidi,crdacc
- common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap,
- * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
- * nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
- * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
- * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv),
- * debugmidi
- logical debugmidi
- common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm)
- * ,miditran(nm),midtc(0:nm)
- common /comevent/ miditime,lasttime
- logical mmacrec,gottempo
- common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
- * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60),
- * mmacrec,gottempo
- character*79 inameq
- common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
- * isig,lastisig,fracindent,widthpt,height,idsig,
- * lnam(nm),inameq(nm)
- logical rename
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
-c
-c Used to be icmm(0:nm); did midi fail when nv>16?
-c
- integer*2 iinsiv(nm),icmm(0:15)
- character*5 versionc
- common /comver/ versionc
-c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/
- data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/
-c Can't remember why these were not consecutive.
-c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/
-c
-c Write Header
-c
- write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6)
- * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240)
- if (debugmidi)
- * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6,
- * 0,1,0,numchan+1,0,240
-c
-c Write the "conductor" track, for keys, meter, and tempos
-c Get the number of bytes in the conductor event stream
-c
- ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec)
- do 15 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec)
-15 continue
-c ib1 = (4+ljob+26+ndata+4)/256
-c ib0 = 4+ljob+26+ndata+4-256*ib1
- ib1 = (4+ljob+27+ndata+4)/256
- ib0 = 4+ljob+27+ndata+4-256*ib1
- write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0)
-c
-c Text header
-c
-c * //char(0)//char(255)//char(1)//char(ljob+26)
- * //char(0)//char(255)//char(1)//char(ljob+27)
- if (debugmidi)
- * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0,
- * 0,255,1,ljob+27
- write(51,'(a,$)')jobname(1:ljob)
- if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"'
-c
-c (separate writes are needed to defeat compiler BUG!!!)
-c
-c write(51,'(a,$)')'.mid, produced by PMX 2.30'
- write(51,'(a,$)')'.mid, produced by PMX '//versionc
- if (debugmidi) write(52,'(a)')
- * '".mid, produced by PMX '//versionc//'"'
-c
-c Conductor event data: Loop over sections.
-c
- do 16 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(numchan,isec)
- else
- mend = imidi(numchan)
- end if
- do 17 i = msecstrt(numchan,isec) , mend
- write(51,'(a,$)')char(mmidi(numchan,i))
- if (debugmidi) write(52,'(z4)')mmidi(numchan,i)
-17 continue
-16 continue
-c
-c And close out the time sig / tempo track.
-c
- write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
-c
-c Loop over track for each voice: The following sets up iv.
-c
- iv = nv
- if (twoline(nv)) then
- kv = 2
- else
- kv = 1
- end if
-c
-c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv)
-c
- nstaves = 0
- ivt = 0
- do 12 iinst = 1 , nm
- nstaves = nstaves+nsperi(iinst)
- do 13 ivtt = 1 , nsperi(iinst)
- ivt = ivt+1
- iinsiv(ivt) = iinst
-13 continue
- if (nstaves .eq. nv) go to 14
-12 continue
- print*,'Screwup!'
- call stop1()
-14 continue
-c
- do 5 icm = 0 , numchan-1
-c
-c Get the number of bytes in the data stream
-c
- ndata = 1+imidi(icm)-msecstrt(icm,nmidsec)
- do 11 isec = 1 , nmidsec-1
- ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec)
-11 continue
-c
-cc Add 3 (for instrum) plus 4 (for closing) to byte count,
-c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count,
-c
-c ndata = ndata+7
- ndata = ndata+11
-c
-c Add 4+lnam(iinsiv(iv)) if lnam>0 ,
-c
- if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv))
-c
-c Separate total byte counts into 4 bytes
-c
- do 2 ibyte = 1 , 4
- if (ndata .gt. 0) then
- byteq(ibyte) = char(mod(ndata,256))
- ndata = ishft(ndata,-8)
- else
- byteq(ibyte) = char(0)
- end if
-2 continue
-c
-c Now write front stuff for this track
-c
- write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1)
- * //char(0)//char(12*16+icmm(icm))//char(midinst(iv))
- * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm))
- if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm,
- * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)),
- * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv),
- * 0,11*16+icmm(icm),10,midbc(icm)
- if (lnam(iinsiv(iv)) .gt. 0) then
-c
-c Add instrument name as sequence name
-c
- write(51,'(a,$)')char(0)//char(255)//char(3)
- * //char(lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv))
- write(51,'(a,$)')
- * inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))
- if (debugmidi) write(52,'(a)')
- * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"'
- end if
- write(tempoq,'(i2)')icm
- write(instq,'(i3)')midinst(iv)
- call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3))
-c
-c Notes: Loop over sections.
-c
- do 9 isec = 1 , nmidsec
- if (isec .lt. nmidsec) then
- mend = msecend(icm,isec)
- else
- mend = imidi(icm)
- end if
- do 10 i = msecstrt(icm,isec) , mend
- write(51,'(a,$)')char(mmidi(icm,i))
- if (debugmidi) write(52,'(z4)')mmidi(icm,i)
-10 continue
-9 continue
-c
-c Closing 4 bytes
-c
- write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0)
- if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0
- if (kv .eq. 2) then
- kv = 1
- else if (iv .eq. 1) then
- go to 5
- else
- iv = iv-1
- if (twoline(iv)) kv=2
- end if
-5 continue
- write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan)
- write(15,'(1x,a12,(10i6))')
- * 'Bytes used:',(imidi(icm),icm=0,numchan)
- close(51)
- if (debugmidi) close(52)
- return
- end
- subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag)
- parameter(nm=24)
- integer*4 iInstTrans(nm),iTransKey(nm)
- character*79 notexq
- character*1 chax
- logical flag
-c
-c Assumes notexq is blank
-c
- do 1 i = 1 , nInstTrans
- notexq = chax(92)//'setsign'
- lnote = 8
- if (iInstTrans(i) .lt. 10) then
- notexq = notexq(1:lnote)//chax(48+iInstTrans(i))
- lnote = lnote+1
- else
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iInstTrans(i),'}'
- lnote = lnote+4
- end if
- if (iTransKey(i) .lt. 0) then
- write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')
- * '{',iTransKey(i),'}'
- lnote = lnote+4
- else
- notexq = notexq(1:lnote)//chax(48+iTransKey(i))
- lnote = lnote+1
- end if
- write(11,'(a)')notexq(1:lnote)//'%'
-1 continue
- flag = .false.
- return
- end
- subroutine writflot(x,notexq,lenline)
- character*(*) notexq
- if (x .lt. 0.95) then
- write(notexq(lenline+1:lenline+2),'(f2.1)')x
- lenline = lenline+2
- else if (x .lt. 9.95) then
- write(notexq(lenline+1:lenline+3),'(f3.1)')x
- lenline = lenline+3
- else
- write(notexq(lenline+1:lenline+4),'(f4.1)')x
- lenline = lenline+4
- end if
- return
- end
- subroutine wsclef(iv,ninow,clefq,nclef)
-c
-c Writes \setclef for instrument containing voice iv
-c
- parameter (nm=24)
- common /comlast/ islast,usevshrink
- logical islast,usevshrink
- common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
- logical rename
- character*1 clefq(nm),chax
- character*20 temq
- if (nclef .lt. 7) then
- clefq(iv) = chax(48+nclef)
- else
- clefq(iv)='9'
- end if
- if (.not.islast) return
- iv1 = 1
- do 1 iinst = 1 , ninow
- if (iv .lt. iv1+nspern(iinst)) go to 2
- iv1 = iv1+nspern(iinst)
-1 continue
- print*
- print*,'Should not be here in wsclef!'
- call stop1()
-2 continue
- iv2 = iv1+nspern(iinst)-1
- if (iinst .lt. 10) then
- temq = chax(92)//'setclef'//chax(48+iinst)
- ltem = 9
- else
- write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}'
- ltem = 12
- end if
- if (iv1 .eq. iv2) then
- write(11,'(a)')temq(1:ltem)//clefq(iv)//'%'
- else
- temq = temq(1:ltem)//'{'
- ltem = ltem+1
- do 3 iiv = iv1 , iv2
- temq = temq(1:ltem)//chax(48+numclef(clefq(iiv)))
- ltem = ltem+1
-3 continue
- write(11,'(a)')temq(1:ltem)//'}%'
- end if
- return
- end
diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f
deleted file mode 100644
index c784301d046..00000000000
--- a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.f
+++ /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 <http://www.gnu.org/licenses/>.
-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 here, so it's ok to get a symbol
-c
- call nextsym(line(iline),len,ipe,ipenew,sym,lsym)
- end if
-c
-c Check for end of block or bar line symbol
-c
- if (index('/|',sym(1:1)) .gt. 0) then
- ipe = ipenew
- go to 4
- else
- wbrest = .false.
- if (alldone) go to 12
- do 5 iw = 1 , nwbrs
- wbrest = wbrest .or. sym(1:lsym).eq.wbrsym(iw)(1:lwbrs)
-5 continue
- wbrest = wbrest .or. (sym(1:lsym).eq.'r'.and.lwbrs.eq.2)
- * .or. (sym(1:lsym).eq.'rd'.and.lwbrs.eq.3)
- * .or. (sym(1:lsym).eq.'rp')
- * .or. (sym(1:lsym).eq.'r' .and. rpfirst)
-12 if (wbrest) then
- ipe = ipenew
- nmbr = nmbr+1
- go to 4
- else
-c
-c AHA! Failed prev. test, so last symbol was *not* mbr.
-c It must be saved, and its starting position is ipenew-lsym+1
-c
- if (nmbr .gt. 1) then
-c
-c Write stuff up to start of mbr
-c
- if (ip1 .gt. 1) write(40,'(a)')line(1)(1:ip1-1)
-c
-c Insert mbr symbol. Always end with a slash just in case next sym must be
-c at start of block. May think this causes undefined octaves, but
-c probably not since it's a single voice.
-c
- ndig = int(alog10(nmbr+.01))+1
- print*,'Inserting rm, iv,nmbr:',iv,nmbr
- write(40,'(a2,i'//char(48+ndig)//',a2)')'rm',nmbr,' /'
- if (alldone) go to 999
- ipc = ipenew-lsym+1
- line(1) = line(iline)(ipc:len)
- else
-c
-c Write old stuff up to end of original lonesome wbr, save the rest.
-c 4 cases: (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) ,
-c alldone.
-c In 1st 2 will have gotten some other lines, so write all up to one b4 last
-c non-comment line; then revert to normal mode on that. In 3rd case must
-c split line.
-c
- if (alldone) then
- write(40,'(a)')line(1)(1:len)
- go to 999
- else if (iline .gt. 1) then
- do 9 il = 1 , iline-1
- len = lenstr(line(il),128)
- write(40,'(a)')line(il)(1:len)
-9 continue
- line(1) = line(iline)
- else
-c
-c Since iline = 1 the wbr is not the last sym, so must split
-c
- write(40,'(a)')line(1)(1:ip1+lwbrsx-1)
- line(1) = line(1)(ip1+lwbrsx+1:len)
- end if
- end if
-c
-c Exit multibar mode
-c
- go to 7
- end if
- end if
- end if
-2 continue
- if (len .gt. 0) then
- write(40,'(a)')line(1)(1:len)
- else
- write(40,'(a)')' '
- end if
-1 continue
-999 continue
- close(10+iv)
- close(40)
- 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 .or. idur.eq.16) 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
- print*,'You entered an invalid note-length value'
- stop
- end if
- if (dotq .eq. 'd') ifnodur = ifnodur*3/2
- return
- end
- subroutine fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
- character*3 wbrsym(2)
- nwbrs = 1
- lwbrs = 2
- if (lenbar .eq. 16) then
- wbrsym(1) = 'r4'
- else if (lenbar .eq. 32) then
- wbrsym(1) = 'r2'
- else if (lenbar .eq. 64) then
- wbrsym(1) = 'r0'
- else if (lenbar .eq. 8) then
- wbrsym(1) = 'r8'
- else if (lenbar .eq. 128) then
- wbrsym(1) = 'r9'
- else
- nwbrs = 2
- lwbrs = 3
- if (lenbar .eq. 24) then
- wbrsym(1) = 'rd4'
- wbrsym(2) = 'r4d'
- else if (lenbar .eq. 48) then
- wbrsym(1) = 'rd2'
- wbrsym(2) = 'r2d'
- else if (lenbar .eq. 96) then
- wbrsym(1) = 'rd0'
- wbrsym(2) = 'r0d'
- else
- write(*,'(33H Any whole-bar rests of duration ,i3,
- * 26H/64 will not be recognized)') lenbar
- end if
- end if
- return
- end
- subroutine nextsym(line,len,ipeold,ipenew,sym,lsym)
-c
-c Know its the last symbol if on return ipenew = len!. So should never
-c be called when ipstart=len.
-c
- character*128 line
- character*80 sym
- if (ipeold .ge. len) then
- print*,'Called nextsym with ipstart>=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.test b/Build/source/utils/pmx/pmx.test
index 61c4a8bbd39..4c9860e66ae 100755
--- a/Build/source/utils/pmx/pmx.test
+++ b/Build/source/utils/pmx/pmx.test
@@ -5,19 +5,19 @@
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 \
+ && 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 \
+ && 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
diff --git a/Build/source/utils/pmx/pmx.1 b/Build/source/utils/pmx/pmx2pdf.1
index 5d699c826b3..9ffcf094377 100644
--- a/Build/source/utils/pmx/pmx.1
+++ b/Build/source/utils/pmx/pmx2pdf.1
@@ -1,12 +1,12 @@
.\" This manpage is licensed under the GNU Public License
-.TH pmx 1 2011-11-28 "pmx script, version 0.2" ""
+.TH pmx2pdf 1 2012-05-15 "pmx2pdf script, version 0.2.1" ""
.SH NAME
-pmx \- This script processes pmx files and then deletes intermediate files
+pmx2pdf \- This script processes pmx files and then deletes intermediate files
.SH SYNOPSIS
[ texlua ]
-.B pmx[.lua]
+.B pmx2pdf
{
.IR option
|
diff --git a/Build/source/utils/pmx/pmx.lua b/Build/source/utils/pmx/pmx2pdf.lua
index 035c9515d93..37790841e5f 100755
--- a/Build/source/utils/pmx/pmx.lua
+++ b/Build/source/utils/pmx/pmx2pdf.lua
@@ -1,11 +1,12 @@
#!/usr/bin/env texlua
-VERSION = "0.2"
+VERSION = "0.2.1"
--[[
- pmx.lua: processes MusiXTeX files using pmxab as a pre-processor (and deletes intermediate files)
+ pmx2pdf: processes MusiXTeX files using pmxab as a pre-processor
+ (and deletes intermediate files)
- (c) Copyright 2011 Bob Tennent rdt@cs.queensu.ca
+ (c) Copyright 2011-12 Bob Tennent rdt@cs.queensu.ca
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
@@ -26,6 +27,9 @@ VERSION = "0.2"
--[[
ChangeLog:
+ version 0.2.1 2012-05-15 RDT
+ renamed to avoid possible name clashes
+
version 0.2 2011-11-28 RDT
added -i (retain intermediate files) option
@@ -34,7 +38,7 @@ VERSION = "0.2"
--]]
function usage()
- print("Usage: [texlua] pmx.lua { option | basename[.pmx] } ... ")
+ print("Usage: [texlua] pmx2pdf { option | basename[.pmx] } ... ")
print("options: -v version")
print(" -h help")
print(" -l latex (or pdflatex)")
@@ -47,7 +51,7 @@ function usage()
end
function whoami ()
- print("This is pmx.lua version ".. VERSION .. ".")
+ print("This is pmx2pdf version ".. VERSION .. ".")
end
whoami()
@@ -138,7 +142,7 @@ repeat
end
end
else
- print("pmx/MusiXTeX processing of " .. filename .. ".pmx fails.\n")
+ print("PMX/MusiXTeX processing of " .. filename .. ".pmx fails.\n")
exit_code = 2
--[[ uncomment for debugging
print("tex = ", tex)
diff --git a/Build/source/utils/pmx/tests/barsant.mid b/Build/source/utils/pmx/tests/barsant.mid
deleted file mode 100644
index ccd7219e2be..00000000000
--- a/Build/source/utils/pmx/tests/barsant.mid
+++ /dev/null
Binary files differ
diff --git a/Build/source/utils/pmx/tests/barsant.pml b/Build/source/utils/pmx/tests/barsant.pml
deleted file mode 100644
index 0c514716522..00000000000
--- a/Build/source/utils/pmx/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/tests/barsant.pmx b/Build/source/utils/pmx/tests/barsant.pmx
deleted file mode 100644
index f10fd67b064..00000000000
--- a/Build/source/utils/pmx/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/tests/barsant.tex b/Build/source/utils/pmx/tests/barsant.tex
deleted file mode 100644
index fe003c3404e..00000000000
--- a/Build/source/utils/pmx/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/tests/barsant1.pmx b/Build/source/utils/pmx/tests/barsant1.pmx
deleted file mode 100644
index 2aea3d406eb..00000000000
--- a/Build/source/utils/pmx/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/tests/barsant2.pmx b/Build/source/utils/pmx/tests/barsant2.pmx
deleted file mode 100644
index a21386f4768..00000000000
--- a/Build/source/utils/pmx/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/w32getc.c b/Build/source/utils/pmx/w32getc.c
deleted file mode 100644
index e9147407298..00000000000
--- a/Build/source/utils/pmx/w32getc.c
+++ /dev/null
@@ -1,14 +0,0 @@
-#include <stdio.h>
-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;
-}