From 68281af04144dc6c216436cdf9e3ceab3c7a80ea Mon Sep 17 00:00:00 2001 From: Peter Breitenlohner Date: Wed, 28 Mar 2012 09:15:53 +0000 Subject: pmx: Update build system and enable cross compilation git-svn-id: svn://tug.org/texlive/trunk@25759 c570f23f-e606-0410-a88d-b1316a301751 --- Build/source/configure | 15 +- Build/source/libs/configure | 15 +- Build/source/texk/configure | 15 +- Build/source/utils/README | 5 +- Build/source/utils/configure | 15 +- Build/source/utils/pmx/ChangeLog | 11 + Build/source/utils/pmx/Makefile.am | 27 +- Build/source/utils/pmx/Makefile.in | 245 +- Build/source/utils/pmx/README | 13 + Build/source/utils/pmx/ac/withenable.ac | 2 +- Build/source/utils/pmx/aclocal.m4 | 1 + Build/source/utils/pmx/arith.h | 3 + Build/source/utils/pmx/configure.ac | 18 +- .../source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes | 5 +- Build/source/utils/pmx/pmx-2.6.17/pmx2617.c | 37856 ------------------- Build/source/utils/pmx/pmx-2.6.17/pmxab.c | 37856 +++++++++++++++++++ 16 files changed, 38033 insertions(+), 38069 deletions(-) create mode 100644 Build/source/utils/pmx/ChangeLog create mode 100644 Build/source/utils/pmx/README create mode 100644 Build/source/utils/pmx/arith.h delete mode 100644 Build/source/utils/pmx/pmx-2.6.17/pmx2617.c create mode 100644 Build/source/utils/pmx/pmx-2.6.17/pmxab.c (limited to 'Build/source') diff --git a/Build/source/configure b/Build/source/configure index e31aa4a6b3b..0232043dcab 100755 --- a/Build/source/configure +++ b/Build/source/configure @@ -3905,24 +3905,15 @@ if test "${enable_pmx+set}" = set; then : enableval=$enable_pmx; fi case $enable_pmx in #( - yes) : - if test "x$cross_compiling" = xyes; then : - as_fn_error $? "Unable to cross compile pmx" "$LINENO" 5 -fi ;; #( - no) : + yes|no) : ;; #( *) : - if test "x$cross_compiling" = xyes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: Cross compiling -> \`--disable-pmx'" >&5 -$as_echo "$as_me: Cross compiling -> \`--disable-pmx'" >&6;} - enable_pmx=no - ac_configure_args="$ac_configure_args '--disable-pmx'" - else + enable_pmx=$enable_all_pkgs { $as_echo "$as_me:${as_lineno-$LINENO}: Assuming \`--enable-pmx=$enable_pmx'" >&5 $as_echo "$as_me: Assuming \`--enable-pmx=$enable_pmx'" >&6;} ac_configure_args="$ac_configure_args '--enable-pmx=$enable_pmx'" - fi ;; + ;; esac diff --git a/Build/source/libs/configure b/Build/source/libs/configure index 08bae746fe8..8a1a95dd6c1 100755 --- a/Build/source/libs/configure +++ b/Build/source/libs/configure @@ -3230,24 +3230,15 @@ if test "${enable_pmx+set}" = set; then : enableval=$enable_pmx; fi case $enable_pmx in #( - yes) : - if test "x$cross_compiling" = xyes; then : - as_fn_error $? "Unable to cross compile pmx" "$LINENO" 5 -fi ;; #( - no) : + yes|no) : ;; #( *) : - if test "x$cross_compiling" = xyes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: Cross compiling -> \`--disable-pmx'" >&5 -$as_echo "$as_me: Cross compiling -> \`--disable-pmx'" >&6;} - enable_pmx=no - ac_configure_args="$ac_configure_args '--disable-pmx'" - else + enable_pmx=$enable_all_pkgs { $as_echo "$as_me:${as_lineno-$LINENO}: Assuming \`--enable-pmx=$enable_pmx'" >&5 $as_echo "$as_me: Assuming \`--enable-pmx=$enable_pmx'" >&6;} ac_configure_args="$ac_configure_args '--enable-pmx=$enable_pmx'" - fi ;; + ;; esac diff --git a/Build/source/texk/configure b/Build/source/texk/configure index cf550301db9..e97d83f408c 100755 --- a/Build/source/texk/configure +++ b/Build/source/texk/configure @@ -3250,24 +3250,15 @@ if test "${enable_pmx+set}" = set; then : enableval=$enable_pmx; fi case $enable_pmx in #( - yes) : - if test "x$cross_compiling" = xyes; then : - as_fn_error $? "Unable to cross compile pmx" "$LINENO" 5 -fi ;; #( - no) : + yes|no) : ;; #( *) : - if test "x$cross_compiling" = xyes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: Cross compiling -> \`--disable-pmx'" >&5 -$as_echo "$as_me: Cross compiling -> \`--disable-pmx'" >&6;} - enable_pmx=no - ac_configure_args="$ac_configure_args '--disable-pmx'" - else + enable_pmx=$enable_all_pkgs { $as_echo "$as_me:${as_lineno-$LINENO}: Assuming \`--enable-pmx=$enable_pmx'" >&5 $as_echo "$as_me: Assuming \`--enable-pmx=$enable_pmx'" >&6;} ac_configure_args="$ac_configure_args '--enable-pmx=$enable_pmx'" - fi ;; + ;; esac diff --git a/Build/source/utils/README b/Build/source/utils/README index 3791dd47e6f..bbad52fa840 100644 --- a/Build/source/utils/README +++ b/Build/source/utils/README @@ -12,9 +12,8 @@ asymptote 2.13 - checked 19jun11 chktex 1.6.4 - checked 25apr11 http://baruch.ev-en.org/proj/chktex/chktex-1.6.4.tar.gz -pmx 2.6.17 - checked 27mar12 - ftp://linus.cs.queensu.ca/pmx-2.6.17.tar.gz - (The version on CTAN is different) +pmx 2.6.17 - checked 28mar12 + http://mirror.ctan.org/support/pmx/ ps2eps 1.68 - checked 25apr11 http://tm.uka.de/~bless/ps2eps diff --git a/Build/source/utils/configure b/Build/source/utils/configure index f626a07dd61..e0e02498b18 100755 --- a/Build/source/utils/configure +++ b/Build/source/utils/configure @@ -3227,24 +3227,15 @@ if test "${enable_pmx+set}" = set; then : enableval=$enable_pmx; fi case $enable_pmx in #( - yes) : - if test "x$cross_compiling" = xyes; then : - as_fn_error $? "Unable to cross compile pmx" "$LINENO" 5 -fi ;; #( - no) : + yes|no) : ;; #( *) : - if test "x$cross_compiling" = xyes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: Cross compiling -> \`--disable-pmx'" >&5 -$as_echo "$as_me: Cross compiling -> \`--disable-pmx'" >&6;} - enable_pmx=no - ac_configure_args="$ac_configure_args '--disable-pmx'" - else + enable_pmx=$enable_all_pkgs { $as_echo "$as_me:${as_lineno-$LINENO}: Assuming \`--enable-pmx=$enable_pmx'" >&5 $as_echo "$as_me: Assuming \`--enable-pmx=$enable_pmx'" >&6;} ac_configure_args="$ac_configure_args '--enable-pmx=$enable_pmx'" - fi ;; + ;; esac diff --git a/Build/source/utils/pmx/ChangeLog b/Build/source/utils/pmx/ChangeLog new file mode 100644 index 00000000000..55f9ad34d9c --- /dev/null +++ b/Build/source/utils/pmx/ChangeLog @@ -0,0 +1,11 @@ +2012-03-28 Peter Breitenlohner + + * arith.h (new): Dummy header to avoid the need to run arithchk. + * Makefile.am, configure.ac: Modified to allow cross compilation. + +2012-03-26 Peter Breitenlohner + + Adapt pmx-2.6.17 to the TeX Live build system. + +Copyright (C) 2012 Peter Breitenlohner +You may freely use, modify and/or distribute this file. diff --git a/Build/source/utils/pmx/Makefile.am b/Build/source/utils/pmx/Makefile.am index ca6538cafed..1e91f08e1e5 100644 --- a/Build/source/utils/pmx/Makefile.am +++ b/Build/source/utils/pmx/Makefile.am @@ -15,32 +15,21 @@ dist-hook: rm -rf `find $(distdir) -name .svn` INCLUDES = -I$(srcdir)/$(PMX_TREE)/libf2c -AM_CPPFLAGS = -DNON_UNIX_STDIO AM_CFLAGS = #$(WARNING_CFLAGS) bin_PROGRAMS = pmxab scor2prt -nodist_pmxab_SOURCES = pmxab.c - -pmxab_LDADD = libf2c.a +pmxab_SOURCES = $(PMX_TREE)/pmxab.c scor2prt_SOURCES = $(PMX_TREE)/scor2prt.c -scor2prt_LDADD = libf2c.a - -noinst_PROGRAMS = arithchk - -arithchk_SOURCES = $(PMX_TREE)/libf2c/arithchk.c - -arithchk_CPPFLAGS = $(ARITHCHK_CPPFLAGS) - -arith.h: arithchk$(EXEEXT) - ./arithchk >$@ +LDADD = libf2c.a 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 \ @@ -69,7 +58,9 @@ libf2c_a_SOURCES += \ $(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/system_.c +## MISC (not used for pmx) +EXTRA_libf2c_a_SOURCES = \ $(PMX_TREE)/libf2c/uninit.c ## POW libf2c_a_SOURCES += \ @@ -230,7 +221,7 @@ libf2c_a_SOURCES += \ $(PMX_TREE)/libf2c/etime_.c ## QINT (unused) -EXTRA_libf2c_a_SOURCES = \ +EXTRA_libf2c_a_SOURCES += \ $(PMX_TREE)/libf2c/ftell64_.c \ $(PMX_TREE)/libf2c/pow_qq.c \ $(PMX_TREE)/libf2c/qbitbits.c \ @@ -239,7 +230,3 @@ EXTRA_libf2c_a_SOURCES = \ EXTRA_libf2c_a_SOURCES += \ $(PMX_TREE)/libf2c/signbit.c -$(libf2c_a_OBJECTS): arith.h - -DISTCLEANFILES = arith.h pmxab.c - diff --git a/Build/source/utils/pmx/Makefile.in b/Build/source/utils/pmx/Makefile.in index c2f31300c89..711629253c8 100644 --- a/Build/source/utils/pmx/Makefile.in +++ b/Build/source/utils/pmx/Makefile.in @@ -34,26 +34,26 @@ NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : bin_PROGRAMS = pmxab$(EXEEXT) scor2prt$(EXEEXT) -noinst_PROGRAMS = arithchk$(EXEEXT) subdir = . -DIST_COMMON = $(am__configure_deps) $(srcdir)/../../build-aux/depcomp \ +DIST_COMMON = README $(am__configure_deps) \ + $(srcdir)/../../build-aux/depcomp \ $(srcdir)/../../build-aux/install-sh \ $(srcdir)/../../build-aux/missing $(srcdir)/Makefile.am \ $(srcdir)/Makefile.in $(top_srcdir)/configure \ - $(top_srcdir)/pmx-2.6.17/pmx2617.c \ ../../build-aux/config.guess ../../build-aux/config.sub \ ../../build-aux/depcomp ../../build-aux/install-sh \ ../../build-aux/ltmain.sh ../../build-aux/missing \ - ../../build-aux/texinfo.tex ../../build-aux/ylwrap + ../../build-aux/texinfo.tex ../../build-aux/ylwrap ChangeLog ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/../../m4/kpse-warnings.m4 \ - $(top_srcdir)/version.ac $(top_srcdir)/configure.ac + $(top_srcdir)/../../m4/kpse-win32.m4 $(top_srcdir)/version.ac \ + $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d -CONFIG_CLEAN_FILES = pmxab.c +CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LIBRARIES = $(noinst_LIBRARIES) AR = ar @@ -66,60 +66,58 @@ am_libf2c_a_OBJECTS = abort_.$(OBJEXT) cabs.$(OBJEXT) derf_.$(OBJEXT) \ getenv_.$(OBJEXT) i77vers.$(OBJEXT) iargc_.$(OBJEXT) \ main.$(OBJEXT) s_paus.$(OBJEXT) s_rnge.$(OBJEXT) \ s_stop.$(OBJEXT) sig_die.$(OBJEXT) signal_.$(OBJEXT) \ - system_.$(OBJEXT) uninit.$(OBJEXT) pow_ci.$(OBJEXT) \ - pow_dd.$(OBJEXT) pow_di.$(OBJEXT) pow_hh.$(OBJEXT) \ - pow_ii.$(OBJEXT) pow_ri.$(OBJEXT) pow_zi.$(OBJEXT) \ - pow_zz.$(OBJEXT) c_abs.$(OBJEXT) c_cos.$(OBJEXT) \ - c_div.$(OBJEXT) c_exp.$(OBJEXT) c_log.$(OBJEXT) \ - c_sin.$(OBJEXT) c_sqrt.$(OBJEXT) z_abs.$(OBJEXT) \ - z_cos.$(OBJEXT) z_div.$(OBJEXT) z_exp.$(OBJEXT) \ - z_log.$(OBJEXT) z_sin.$(OBJEXT) z_sqrt.$(OBJEXT) \ - r_abs.$(OBJEXT) r_acos.$(OBJEXT) r_asin.$(OBJEXT) \ - r_atan.$(OBJEXT) r_atn2.$(OBJEXT) r_cnjg.$(OBJEXT) \ - r_cos.$(OBJEXT) r_cosh.$(OBJEXT) r_dim.$(OBJEXT) \ - r_exp.$(OBJEXT) r_imag.$(OBJEXT) r_int.$(OBJEXT) \ - r_lg10.$(OBJEXT) r_log.$(OBJEXT) r_mod.$(OBJEXT) \ - r_nint.$(OBJEXT) r_sign.$(OBJEXT) r_sin.$(OBJEXT) \ - r_sinh.$(OBJEXT) r_sqrt.$(OBJEXT) r_tan.$(OBJEXT) \ - r_tanh.$(OBJEXT) d_abs.$(OBJEXT) d_acos.$(OBJEXT) \ - d_asin.$(OBJEXT) d_atan.$(OBJEXT) d_atn2.$(OBJEXT) \ - d_cnjg.$(OBJEXT) d_cos.$(OBJEXT) d_cosh.$(OBJEXT) \ - d_dim.$(OBJEXT) d_exp.$(OBJEXT) d_imag.$(OBJEXT) \ - d_int.$(OBJEXT) d_lg10.$(OBJEXT) d_log.$(OBJEXT) \ - d_mod.$(OBJEXT) d_nint.$(OBJEXT) d_prod.$(OBJEXT) \ - d_sign.$(OBJEXT) d_sin.$(OBJEXT) d_sinh.$(OBJEXT) \ - d_sqrt.$(OBJEXT) d_tan.$(OBJEXT) d_tanh.$(OBJEXT) \ - i_abs.$(OBJEXT) i_dim.$(OBJEXT) i_dnnt.$(OBJEXT) \ - i_indx.$(OBJEXT) i_len.$(OBJEXT) i_mod.$(OBJEXT) \ - i_nint.$(OBJEXT) i_sign.$(OBJEXT) lbitbits.$(OBJEXT) \ - lbitshft.$(OBJEXT) h_abs.$(OBJEXT) h_dim.$(OBJEXT) \ - h_dnnt.$(OBJEXT) h_indx.$(OBJEXT) h_len.$(OBJEXT) \ - h_mod.$(OBJEXT) h_nint.$(OBJEXT) h_sign.$(OBJEXT) \ - hl_ge.$(OBJEXT) hl_gt.$(OBJEXT) hl_le.$(OBJEXT) \ - hl_lt.$(OBJEXT) l_ge.$(OBJEXT) l_gt.$(OBJEXT) l_le.$(OBJEXT) \ - l_lt.$(OBJEXT) ef1asc_.$(OBJEXT) ef1cmc_.$(OBJEXT) \ - f77_aloc.$(OBJEXT) s_cat.$(OBJEXT) s_cmp.$(OBJEXT) \ - s_copy.$(OBJEXT) backspac.$(OBJEXT) close.$(OBJEXT) \ - dfe.$(OBJEXT) dolio.$(OBJEXT) due.$(OBJEXT) endfile.$(OBJEXT) \ - err.$(OBJEXT) fmt.$(OBJEXT) fmtlib.$(OBJEXT) ftell_.$(OBJEXT) \ - iio.$(OBJEXT) ilnw.$(OBJEXT) inquire.$(OBJEXT) lread.$(OBJEXT) \ - lwrite.$(OBJEXT) open.$(OBJEXT) rdfmt.$(OBJEXT) \ - rewind.$(OBJEXT) rsfe.$(OBJEXT) rsli.$(OBJEXT) rsne.$(OBJEXT) \ - sfe.$(OBJEXT) sue.$(OBJEXT) typesize.$(OBJEXT) uio.$(OBJEXT) \ - util.$(OBJEXT) wref.$(OBJEXT) wrtfmt.$(OBJEXT) wsfe.$(OBJEXT) \ - wsle.$(OBJEXT) wsne.$(OBJEXT) xwsne.$(OBJEXT) dtime_.$(OBJEXT) \ - etime_.$(OBJEXT) + system_.$(OBJEXT) pow_ci.$(OBJEXT) pow_dd.$(OBJEXT) \ + pow_di.$(OBJEXT) pow_hh.$(OBJEXT) pow_ii.$(OBJEXT) \ + pow_ri.$(OBJEXT) pow_zi.$(OBJEXT) pow_zz.$(OBJEXT) \ + c_abs.$(OBJEXT) c_cos.$(OBJEXT) c_div.$(OBJEXT) \ + c_exp.$(OBJEXT) c_log.$(OBJEXT) c_sin.$(OBJEXT) \ + c_sqrt.$(OBJEXT) z_abs.$(OBJEXT) z_cos.$(OBJEXT) \ + z_div.$(OBJEXT) z_exp.$(OBJEXT) z_log.$(OBJEXT) \ + z_sin.$(OBJEXT) z_sqrt.$(OBJEXT) r_abs.$(OBJEXT) \ + r_acos.$(OBJEXT) r_asin.$(OBJEXT) r_atan.$(OBJEXT) \ + r_atn2.$(OBJEXT) r_cnjg.$(OBJEXT) r_cos.$(OBJEXT) \ + r_cosh.$(OBJEXT) r_dim.$(OBJEXT) r_exp.$(OBJEXT) \ + r_imag.$(OBJEXT) r_int.$(OBJEXT) r_lg10.$(OBJEXT) \ + r_log.$(OBJEXT) r_mod.$(OBJEXT) r_nint.$(OBJEXT) \ + r_sign.$(OBJEXT) r_sin.$(OBJEXT) r_sinh.$(OBJEXT) \ + r_sqrt.$(OBJEXT) r_tan.$(OBJEXT) r_tanh.$(OBJEXT) \ + d_abs.$(OBJEXT) d_acos.$(OBJEXT) d_asin.$(OBJEXT) \ + d_atan.$(OBJEXT) d_atn2.$(OBJEXT) d_cnjg.$(OBJEXT) \ + d_cos.$(OBJEXT) d_cosh.$(OBJEXT) d_dim.$(OBJEXT) \ + d_exp.$(OBJEXT) d_imag.$(OBJEXT) d_int.$(OBJEXT) \ + d_lg10.$(OBJEXT) d_log.$(OBJEXT) d_mod.$(OBJEXT) \ + d_nint.$(OBJEXT) d_prod.$(OBJEXT) d_sign.$(OBJEXT) \ + d_sin.$(OBJEXT) d_sinh.$(OBJEXT) d_sqrt.$(OBJEXT) \ + d_tan.$(OBJEXT) d_tanh.$(OBJEXT) i_abs.$(OBJEXT) \ + i_dim.$(OBJEXT) i_dnnt.$(OBJEXT) i_indx.$(OBJEXT) \ + i_len.$(OBJEXT) i_mod.$(OBJEXT) i_nint.$(OBJEXT) \ + i_sign.$(OBJEXT) lbitbits.$(OBJEXT) lbitshft.$(OBJEXT) \ + h_abs.$(OBJEXT) h_dim.$(OBJEXT) h_dnnt.$(OBJEXT) \ + h_indx.$(OBJEXT) h_len.$(OBJEXT) h_mod.$(OBJEXT) \ + h_nint.$(OBJEXT) h_sign.$(OBJEXT) hl_ge.$(OBJEXT) \ + hl_gt.$(OBJEXT) hl_le.$(OBJEXT) hl_lt.$(OBJEXT) l_ge.$(OBJEXT) \ + l_gt.$(OBJEXT) l_le.$(OBJEXT) l_lt.$(OBJEXT) ef1asc_.$(OBJEXT) \ + ef1cmc_.$(OBJEXT) f77_aloc.$(OBJEXT) s_cat.$(OBJEXT) \ + s_cmp.$(OBJEXT) s_copy.$(OBJEXT) backspac.$(OBJEXT) \ + close.$(OBJEXT) dfe.$(OBJEXT) dolio.$(OBJEXT) due.$(OBJEXT) \ + endfile.$(OBJEXT) err.$(OBJEXT) fmt.$(OBJEXT) fmtlib.$(OBJEXT) \ + ftell_.$(OBJEXT) iio.$(OBJEXT) ilnw.$(OBJEXT) \ + inquire.$(OBJEXT) lread.$(OBJEXT) lwrite.$(OBJEXT) \ + open.$(OBJEXT) rdfmt.$(OBJEXT) rewind.$(OBJEXT) rsfe.$(OBJEXT) \ + rsli.$(OBJEXT) rsne.$(OBJEXT) sfe.$(OBJEXT) sue.$(OBJEXT) \ + typesize.$(OBJEXT) uio.$(OBJEXT) util.$(OBJEXT) wref.$(OBJEXT) \ + wrtfmt.$(OBJEXT) wsfe.$(OBJEXT) wsle.$(OBJEXT) wsne.$(OBJEXT) \ + xwsne.$(OBJEXT) dtime_.$(OBJEXT) etime_.$(OBJEXT) libf2c_a_OBJECTS = $(am_libf2c_a_OBJECTS) am__installdirs = "$(DESTDIR)$(bindir)" -PROGRAMS = $(bin_PROGRAMS) $(noinst_PROGRAMS) -am_arithchk_OBJECTS = arithchk-arithchk.$(OBJEXT) -arithchk_OBJECTS = $(am_arithchk_OBJECTS) -arithchk_LDADD = $(LDADD) -nodist_pmxab_OBJECTS = pmxab.$(OBJEXT) -pmxab_OBJECTS = $(nodist_pmxab_OBJECTS) +PROGRAMS = $(bin_PROGRAMS) +am_pmxab_OBJECTS = pmxab.$(OBJEXT) +pmxab_OBJECTS = $(am_pmxab_OBJECTS) +pmxab_LDADD = $(LDADD) pmxab_DEPENDENCIES = libf2c.a 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 @@ -130,10 +128,9 @@ COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ CCLD = $(CC) LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ SOURCES = $(libf2c_a_SOURCES) $(EXTRA_libf2c_a_SOURCES) \ - $(arithchk_SOURCES) $(nodist_pmxab_SOURCES) \ - $(scor2prt_SOURCES) + $(pmxab_SOURCES) $(scor2prt_SOURCES) DIST_SOURCES = $(libf2c_a_SOURCES) $(EXTRA_libf2c_a_SOURCES) \ - $(arithchk_SOURCES) $(scor2prt_SOURCES) + $(pmxab_SOURCES) $(scor2prt_SOURCES) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) @@ -153,7 +150,7 @@ am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ -ARITHCHK_CPPFLAGS = @ARITHCHK_CPPFLAGS@ +AM_CPPFLAGS = @AM_CPPFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ @@ -246,29 +243,25 @@ top_srcdir = @top_srcdir@ ACLOCAL_AMFLAGS = -I ../../m4 EXTRA_DIST = $(PMX_TREE) $(PMX_TREE)-PATCHES INCLUDES = -I$(srcdir)/$(PMX_TREE)/libf2c -AM_CPPFLAGS = -DNON_UNIX_STDIO AM_CFLAGS = #$(WARNING_CFLAGS) -nodist_pmxab_SOURCES = pmxab.c -pmxab_LDADD = libf2c.a +pmxab_SOURCES = $(PMX_TREE)/pmxab.c scor2prt_SOURCES = $(PMX_TREE)/scor2prt.c -scor2prt_LDADD = libf2c.a -arithchk_SOURCES = $(PMX_TREE)/libf2c/arithchk.c -arithchk_CPPFLAGS = $(ARITHCHK_CPPFLAGS) +LDADD = libf2c.a noinst_LIBRARIES = libf2c.a -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/uninit.c \ +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 \ @@ -336,10 +329,10 @@ libf2c_a_SOURCES = $(PMX_TREE)/libf2c/f2c.h $(PMX_TREE)/libf2c/fio.h \ $(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 -EXTRA_libf2c_a_SOURCES = $(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 -DISTCLEANFILES = arith.h pmxab.c +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 all: all-am .SUFFIXES: @@ -422,12 +415,6 @@ uninstall-binPROGRAMS: clean-binPROGRAMS: -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS) - -clean-noinstPROGRAMS: - -test -z "$(noinst_PROGRAMS)" || rm -f $(noinst_PROGRAMS) -arithchk$(EXEEXT): $(arithchk_OBJECTS) $(arithchk_DEPENDENCIES) $(EXTRA_arithchk_DEPENDENCIES) - @rm -f arithchk$(EXEEXT) - $(LINK) $(arithchk_OBJECTS) $(arithchk_LDADD) $(LIBS) pmxab$(EXEEXT): $(pmxab_OBJECTS) $(pmxab_DEPENDENCIES) $(EXTRA_pmxab_DEPENDENCIES) @rm -f pmxab$(EXEEXT) $(LINK) $(pmxab_OBJECTS) $(pmxab_LDADD) $(LIBS) @@ -442,7 +429,6 @@ distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/abort_.Po@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/arithchk-arithchk.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backspac.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/c_abs.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/c_cos.Po@am__quote@ @@ -883,20 +869,6 @@ system_.obj: $(PMX_TREE)/libf2c/system_.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 system_.obj `if test -f '$(PMX_TREE)/libf2c/system_.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/system_.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/system_.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 -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/uninit.c' object='uninit.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 uninit.o `test -f '$(PMX_TREE)/libf2c/uninit.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/uninit.c - -uninit.obj: $(PMX_TREE)/libf2c/uninit.c -@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT uninit.obj -MD -MP -MF $(DEPDIR)/uninit.Tpo -c -o uninit.obj `if test -f '$(PMX_TREE)/libf2c/uninit.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/uninit.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/uninit.c'; fi` -@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/uninit.Tpo $(DEPDIR)/uninit.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/uninit.c' object='uninit.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 uninit.obj `if test -f '$(PMX_TREE)/libf2c/uninit.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/uninit.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/uninit.c'; fi` - pow_ci.o: $(PMX_TREE)/libf2c/pow_ci.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pow_ci.o -MD -MP -MF $(DEPDIR)/pow_ci.Tpo -c -o pow_ci.o `test -f '$(PMX_TREE)/libf2c/pow_ci.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/pow_ci.c @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/pow_ci.Tpo $(DEPDIR)/pow_ci.Po @@ -2759,6 +2731,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` +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 +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/uninit.c' object='uninit.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 uninit.o `test -f '$(PMX_TREE)/libf2c/uninit.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/uninit.c + +uninit.obj: $(PMX_TREE)/libf2c/uninit.c +@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT uninit.obj -MD -MP -MF $(DEPDIR)/uninit.Tpo -c -o uninit.obj `if test -f '$(PMX_TREE)/libf2c/uninit.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/uninit.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/uninit.c'; fi` +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/uninit.Tpo $(DEPDIR)/uninit.Po +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/uninit.c' object='uninit.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 uninit.obj `if test -f '$(PMX_TREE)/libf2c/uninit.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/uninit.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/uninit.c'; fi` + ftell64_.o: $(PMX_TREE)/libf2c/ftell64_.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT ftell64_.o -MD -MP -MF $(DEPDIR)/ftell64_.Tpo -c -o ftell64_.o `test -f '$(PMX_TREE)/libf2c/ftell64_.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/ftell64_.c @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/ftell64_.Tpo $(DEPDIR)/ftell64_.Po @@ -2829,19 +2815,19 @@ signbit.obj: $(PMX_TREE)/libf2c/signbit.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 signbit.obj `if test -f '$(PMX_TREE)/libf2c/signbit.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/signbit.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/signbit.c'; fi` -arithchk-arithchk.o: $(PMX_TREE)/libf2c/arithchk.c -@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(arithchk_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT arithchk-arithchk.o -MD -MP -MF $(DEPDIR)/arithchk-arithchk.Tpo -c -o arithchk-arithchk.o `test -f '$(PMX_TREE)/libf2c/arithchk.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/arithchk.c -@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/arithchk-arithchk.Tpo $(DEPDIR)/arithchk-arithchk.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/arithchk.c' object='arithchk-arithchk.o' libtool=no @AMDEPBACKSLASH@ +pmxab.o: $(PMX_TREE)/pmxab.c +@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pmxab.o -MD -MP -MF $(DEPDIR)/pmxab.Tpo -c -o pmxab.o `test -f '$(PMX_TREE)/pmxab.c' || echo '$(srcdir)/'`$(PMX_TREE)/pmxab.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/pmxab.Tpo $(DEPDIR)/pmxab.Po +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/pmxab.c' object='pmxab.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(arithchk_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o arithchk-arithchk.o `test -f '$(PMX_TREE)/libf2c/arithchk.c' || echo '$(srcdir)/'`$(PMX_TREE)/libf2c/arithchk.c +@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pmxab.o `test -f '$(PMX_TREE)/pmxab.c' || echo '$(srcdir)/'`$(PMX_TREE)/pmxab.c -arithchk-arithchk.obj: $(PMX_TREE)/libf2c/arithchk.c -@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(arithchk_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT arithchk-arithchk.obj -MD -MP -MF $(DEPDIR)/arithchk-arithchk.Tpo -c -o arithchk-arithchk.obj `if test -f '$(PMX_TREE)/libf2c/arithchk.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/arithchk.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/arithchk.c'; fi` -@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/arithchk-arithchk.Tpo $(DEPDIR)/arithchk-arithchk.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/libf2c/arithchk.c' object='arithchk-arithchk.obj' libtool=no @AMDEPBACKSLASH@ +pmxab.obj: $(PMX_TREE)/pmxab.c +@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pmxab.obj -MD -MP -MF $(DEPDIR)/pmxab.Tpo -c -o pmxab.obj `if test -f '$(PMX_TREE)/pmxab.c'; then $(CYGPATH_W) '$(PMX_TREE)/pmxab.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/pmxab.c'; fi` +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/pmxab.Tpo $(DEPDIR)/pmxab.Po +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(PMX_TREE)/pmxab.c' object='pmxab.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(arithchk_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o arithchk-arithchk.obj `if test -f '$(PMX_TREE)/libf2c/arithchk.c'; then $(CYGPATH_W) '$(PMX_TREE)/libf2c/arithchk.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/libf2c/arithchk.c'; fi` +@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pmxab.obj `if test -f '$(PMX_TREE)/pmxab.c'; then $(CYGPATH_W) '$(PMX_TREE)/pmxab.c'; else $(CYGPATH_W) '$(srcdir)/$(PMX_TREE)/pmxab.c'; fi` scor2prt.o: $(PMX_TREE)/scor2prt.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT scor2prt.o -MD -MP -MF $(DEPDIR)/scor2prt.Tpo -c -o scor2prt.o `test -f '$(PMX_TREE)/scor2prt.c' || echo '$(srcdir)/'`$(PMX_TREE)/scor2prt.c @@ -3107,7 +3093,6 @@ clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) - -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @@ -3115,7 +3100,7 @@ maintainer-clean-generic: clean: clean-am clean-am: clean-binPROGRAMS clean-generic clean-noinstLIBRARIES \ - clean-noinstPROGRAMS mostlyclean-am + mostlyclean-am distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) @@ -3188,18 +3173,17 @@ uninstall-am: uninstall-binPROGRAMS .MAKE: install-am install-strip .PHONY: CTAGS GTAGS all all-am am--refresh check check-am clean \ - clean-binPROGRAMS clean-generic clean-noinstLIBRARIES \ - clean-noinstPROGRAMS ctags dist dist-all dist-bzip2 dist-gzip \ - dist-hook dist-lzip dist-lzma dist-shar dist-tarZ dist-xz \ - dist-zip distcheck distclean distclean-compile \ - 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-pdf install-pdf-am \ - install-ps install-ps-am install-strip installcheck \ - installcheck-am installdirs maintainer-clean \ + clean-binPROGRAMS clean-generic clean-noinstLIBRARIES ctags \ + dist dist-all dist-bzip2 dist-gzip dist-hook dist-lzip \ + dist-lzma dist-shar dist-tarZ dist-xz dist-zip distcheck \ + distclean distclean-compile 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-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 @@ -3209,11 +3193,6 @@ uninstall-am: uninstall-binPROGRAMS dist-hook: rm -rf `find $(distdir) -name .svn` -arith.h: arithchk$(EXEEXT) - ./arithchk >$@ - -$(libf2c_a_OBJECTS): arith.h - # 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. .NOEXPORT: diff --git a/Build/source/utils/pmx/README b/Build/source/utils/pmx/README new file mode 100644 index 00000000000..fb6c3cc6c05 --- /dev/null +++ b/Build/source/utils/pmx/README @@ -0,0 +1,13 @@ +Copyright (C) 2012 Peter Breitenlohner +You may freely use, modify and/or distribute this file. + +In order to build pmx we don't need the complete libf2c library. +Specifically, we can omit uninit.c and with it the necessity to build and +run arithchk in order to create the arith.h header file (which would make +cross compilation impossible). + +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. + + diff --git a/Build/source/utils/pmx/ac/withenable.ac b/Build/source/utils/pmx/ac/withenable.ac index 92b8b0ea2fb..a77f24e150d 100644 --- a/Build/source/utils/pmx/ac/withenable.ac +++ b/Build/source/utils/pmx/ac/withenable.ac @@ -4,4 +4,4 @@ dnl Copyright (C) 2012 Peter Breitenlohner dnl You may freely use, modify and/or distribute this file. dnl ## configure options and TL libraries required for pmx -KPSE_ENABLE_PROG([pmx], , [native]) +KPSE_ENABLE_PROG([pmx]) diff --git a/Build/source/utils/pmx/aclocal.m4 b/Build/source/utils/pmx/aclocal.m4 index 6707d2f7d86..a0ccb48982e 100644 --- a/Build/source/utils/pmx/aclocal.m4 +++ b/Build/source/utils/pmx/aclocal.m4 @@ -1010,3 +1010,4 @@ AC_SUBST([am__untar]) ]) # _AM_PROG_TAR m4_include([../../m4/kpse-warnings.m4]) +m4_include([../../m4/kpse-win32.m4]) diff --git a/Build/source/utils/pmx/arith.h b/Build/source/utils/pmx/arith.h new file mode 100644 index 00000000000..0ee9308ca06 --- /dev/null +++ b/Build/source/utils/pmx/arith.h @@ -0,0 +1,3 @@ +/* Copyright (C) 2012 Peter Breitenlohner + * You may freely use, modify and/or distribute this file. + */ diff --git a/Build/source/utils/pmx/configure.ac b/Build/source/utils/pmx/configure.ac index 0c6d87b8347..619ba223f67 100644 --- a/Build/source/utils/pmx/configure.ac +++ b/Build/source/utils/pmx/configure.ac @@ -9,7 +9,7 @@ dnl m4_include([version.ac])[] dnl define pmx_version AC_INIT([pmx for TeX Live], pmx_version, [tex-k@tug.org]) AC_PREREQ([2.65]) -AC_CONFIG_SRCDIR([pmx-]pmx_version[/scor2prt.c]) +AC_CONFIG_SRCDIR([pmx-]pmx_version[/pmxab.c]) AC_CONFIG_AUX_DIR([../../build-aux]) AC_CONFIG_MACRO_DIR([../../m4]) @@ -21,6 +21,15 @@ AC_PROG_CC KPSE_COMPILER_WARNINGS +dnl initial value for AM_CPPFLAGS +AC_SUBST([AM_CPPFLAGS], ['-DNON_UNIX_STDIO']) + +dnl WIN32 has no +KPSE_CHECK_WIN32 +if test "x$kpse_cv_have_win32" != xno; then + AM_CPPFLAGS="$AM_CPPPFLAGS -DUSE_CLOCK" +fi + dnl Checks for programs. AC_PROG_INSTALL AC_PROG_LN_S @@ -31,13 +40,8 @@ AC_SEARCH_LIBS([sqrt], [m]) AC_CHECK_SIZEOF([long long]) if test $ac_cv_sizeof_long_long -lt 8; then - ARITHCHK_CPPFLAGS='-DNO_LONG_LONG -DNO_FPINIT' -else - ARITHCHK_CPPFLAGS='-DNO_FPINIT' + AM_CPPFLAGS="$AM_CPPPFLAGS -DNO_LONG_LONG" fi -AC_SUBST([ARITHCHK_CPPFLAGS]) - -AC_CONFIG_LINKS([pmxab.c:pmx-]pmx_version[/pmx]m4_bpatsubsts(pmx_version, [\.], [])[.c]) AC_SUBST([PMX_TREE], [pmx-]pmx_version) 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 index 73ea7f65136..d5b53310f25 100644 --- a/Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes +++ b/Build/source/utils/pmx/pmx-2.6.17-PATCHES/TL-Changes @@ -1,5 +1,8 @@ Changes applied to the pmx-2.6.17 tree as obtained from: - ftp://linus.cs.queensu.ca/pmx-2.6.17.tar.gz + http://www.ctan.org/tex-archive/support/pmx/ + +Rename: + pmx2617.c -> pmxab.c Remove: Makefile.in diff --git a/Build/source/utils/pmx/pmx-2.6.17/pmx2617.c b/Build/source/utils/pmx/pmx-2.6.17/pmx2617.c deleted file mode 100644 index 763d8505f50..00000000000 --- a/Build/source/utils/pmx/pmx-2.6.17/pmx2617.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 . */ - - - -/* 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 / */ -/* because it was screwing up linux-compiled versions */ -/* Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) */ -/* 2.616 (111110) */ -/* Allow hairpins to span multiple notes groups (gulps). */ -/* 2.615+ (110810) */ -/* Fix midi when some instruments are transposed, by subtracting */ -/* iTransAmt(instno(iv)) from pitch values sent to via addmidi in */ -/* make2bar.for (for main notes) and docrd (for chord notes) */ -/* 2.615 (110725) */ -/* Fig bug with size-setting (in topfile) when instrument has >1 staves */ -/* 2.615 (110724) */ -/* Make AS[0|-|s|t]... really set sizes */ -/* 2.614 */ -/* Mod notex.for to fix Terry's bug with raised dotted rests (caused */ -/* by double-hboxing). */ -/* 2.613 */ -/* Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. */ -/* 2.612 */ -/* Enhance AS to allow s or t for smallsize or tinysize */ -/* 2.611 */ -/* Error trap for "D" before any notes in a block. */ -/* 2.610 */ -/* Instrument-wise key changes and transposition (incomplete) */ -/* 2.603 */ -/* 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors */ -/* following reading in an include file. */ -/* 101121 Added some error messages in g1etset.for setup data */ -/* 2.602 */ -/* Correct slur indexing in linebreakslurs. */ -/* Account for comment lines in line count for error messages */ -/* 2.601 */ -/* Bug fix: allow 24 slurs with graces */ -/* 2.60 Changes made make it really big */ -/* increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o */ -/* major reprogramming, and 16 may also be a problem (icmm) */ -/* nm=24 (voices) done */ -/* 24 slurs done */ -/* 24 simultaneous beams (Replace index 24 by 0, so get 0-23) */ -/* bufq*131072 (gfortran only) */ -/* getarg syntax (gfortran only) */ -/* 2.523+ */ -/* Fix voice numbering for normal dynamics and text dynamics */ -/* 2.523 */ -/* Version of bigpmx first posted to Hiroaki's web site. */ -/* 2.522 */ -/* 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. */ -/* With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. */ -/* 5/13/10 Fix log2 function */ -/* 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. */ -/* 2.521+ */ -/* 091025 Enable dotting 2nd part of linebreak slur or tie. */ -/* To adjust barno height due to linebreak slur, use \bnrs instead of */ -/* explicitly redefining \raisebarno (pmxb) */ -/* 2.521 */ -/* Bugfix */ -/* 2.520 */ -/* 090519 Enable ligfonts (special figured bass characters) */ -/* 2.519 */ -/* Fix another bug which kept \sk from being output so misaligned some notes. */ -/* 2.518 */ -/* Fix bugs: referencing fig data, char declaration for member of */ -/* common/comfig/ */ -/* 2.517 */ -/* Allow figures in voice 1 + any one other. */ -/* 2.516 */ -/* Allow figures in voice #2 */ -/* 2.515+ to do: Change manual and activate rule against clef change in voice #2. */ -/* 2.515 */ -/* 071222 Changes in getnote to allow auto forced beams to start anywhere. */ -/* 071206 In make2bar, shift fermataup7 to left over centered pause. */ -/* 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line */ -/* staff (it was screwing up vertical justification). */ -/* n34 for tweaks to midi durations of quarter note septuplets. */ -/* To do: In ref250.tex, the tables where 's,t,)' is explained, the line */ -/* [+,- i] ... Vertical adjustment of the start of second segment */ -/* should it be replaced by */ -/* [s +,- i] ... Vertical adjustment of the start of second segment */ -/* 2.514 */ -/* Changes in make2bar to get horizontal spacing right when normal grace */ -/* follows after grace */ -/* Changes in dograce to get octaves right for any material entered inside */ -/* \gaft, which shields transpose register changes from the outside world. */ -/* 2.513 */ -/* In make1bar, near end, for forced beams starting with a rest, copy hgt and */ -/* slope tweaks to ALL notes after first, not just the second one, so if */ -/* there's more than one rest at start the tweaks are still observed. */ -/* In beamid and beamend, add stand-alone triply-flagged notes for xtups. */ -/* 2.512 */ -/* Near end of pmxb, fix error trap to allow redundant 'RD' */ -/* Enable multiplicity down-up '][' within xtup. */ -/* 2.511 */ -/* Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by */ -/* adjusteskz as in bar 7 of barsant. */ -/* 2.510a */ -/* Test: remove restriction on tempo changes in MIDI macros */ -/* Send to CM for beta testing. */ -/* 2.509+ */ -/* To do: Correct manual on AS. "-" is for smaller staves. */ -/* 2.510 */ -/* Forgot to declare litq, voltxtq as character in subroutine getgrace */ -/* 2.509 */ -/* Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) */ -/* 2.508 */ -/* Allow graces in xtups. New subroutine getgrace. */ -/* 2.507 */ -/* To do: Raise/lower figures. */ -/* To do: Add 24, 29 to list of musicsizes in manual */ -/* New sub adjusteskz to account for ask's when computing lengths of */ -/* brackets for unbeamed xtups, slopes and horizontal posn's of number */ -/* Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags */ -/* Add look-left option for keyboard rests, "L" in rest command, set iornq(30) */ -/* 2.506 */ -/* Fix bug with AK, when simultaneous rests have same duration, use defaults. */ -/* 2.505 */ -/* Keyboard rests AK */ -/* 2.504 */ -/* Space after normal grace: option X[n] */ -/* Fixed og when nv .ne. noinst, by using sepsymq instead of '&' */ -/* (To do) length of xtup bracket when there is added non-collision space. */ -/* Trap musicsize if .ne. 16,20,24,29. */ -/* 2.503 */ -/* Enable arpeggio left shift with ?-x */ -/* To do: In manual, arpeggio over 2 staves. */ -/* Allow musicsize of 24 and 29. Had to define meter font size explicitly, */ -/* also change font size for text dynamics, but not much else so far. */ -/* Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn */ -/* was called, causing error in printing replacement number. */ -/* 2.502 */ -/* Incorporate Dirk Laurie's patch to use { , } , for ties. */ -/* Figure height adjustment: append +[n] */ -/* Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) */ -/* 2.501 */ -/* Readjust horizontal offset back to .8 in LineBreakTies */ -/* Fix zero-subscript (iudorn) in putorn */ -/* 2.50 */ -/* Increase number of text-dynamics (dimension of txtdynq) per block */ -/* from 12 to 41. */ -/* Slur option n to override altered default curvature. */ -/* Allow default ps slur curvature tweaks with Ap+/-c */ -/* 2.416 */ -/* Increase length of textdynq from 24 to 128 */ -/* (Todo) Add comment in manual about blank lines at end. */ -/* Configuration file: Define subroutine getpmxmod, check path in environment */ -/* variable pmxmoddir, check existence, read lines into bufq after setup. */ -/* Increase dimension on idynn in dodyn from 4 to 10 for max number */ -/* of marks in a bar */ -/* Increase allowable # of lines from 2000 to 4000. */ -/* (To do) Replace definition of \liftpausc per Olivier. */ -/* (To do) Fix extraneous error message if RD is placed at very end. */ -/* 2.415 */ -/* Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt */ -/* instead of redefining \xnum. Change font used to \smallfont (as for */ -/* normal xtups, */ -/* Allow slur to start on rest. */ -/* 2.414 */ -/* Correct bug in crdacc when adding accidental to boundary causes number of */ -/* segments to decrease */ -/* Special rule for 3-accidental chords: If no 2nds, place them in order */ -/* top, bottom, middle. */ -/* 2.413 */ -/* Correct bugs in chordal accidentals, related to left-shifted noteheads */ -/* (a) Special problems with downstem when main note needs shifting */ -/* (b) Assign 0 rank to boundary segs due to left-shifted noteheads */ -/* 2.412 */ -/* Change default horiz shift of start of seg 2 of linebreak slurs: */ -/* -.7 for slurs, -1.2 for ties, */ -/* Use height of start of seg 1 slur itself for end of 1 and start of 2. */ -/* 2.411 */ -/* "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. */ -/* "s" option in start of slur/tie as precursor to vert/horiz tweaks for end */ -/* of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. */ -/* With "Apl", curvature adjustments on starting slur command apply to seg 1, */ -/* those on ending command to seg 2. */ -/* 2.410 */ -/* "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine */ -/* \xnum, \unbkt, \ovbkt. */ -/* "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is */ -/* flag, mult(5-9) is tweak value+16 */ -/* 2.409 */ -/* Bugfix in docrd for MIDI: Use original pitch in case main/chord were */ -/* switched due to 2nds. */ -/* Remove "o" from error message for "A" command. */ -/* New syntax: optional instrument number separator ":" in movement */ -/* break command to precede a 2-digit instrument. */ -/* Conditional output formats for \setname at movement break to allow */ -/* instrument numbers >9. */ -/* Bugfix in coding to raise barno due to slur over line break (pmxb) */ -/* Move date/version data statement in pmxab to a better place. */ -/* 2.408 */ -/* Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). */ -/* Bug fix in \liftPAusep in notex.for and in pmx.tex */ -/* Character variables for version and date */ -/* For up-stem single graces slurred to down-stem, shift slur start left by */ -/* 0.8 so slur doesn't get too short. */ -/* Initialize and slide mult, same as other full-program variables in /all/. */ -/* 2.407 */ -/* Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, */ -/* 2.406 */ -/* Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing */ -/* equalization). */ -/* Put dimensions of double sharps and flats in crdacc (for chords). */ -/* Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' */ -/* Use only first 4 bits of mult for multiplicity+8, so rest can be used */ -/* for other stuff. */ -/* Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. */ -/* 2.405: Not published but saved for safety. */ -/* Option Aph to write \special{header=psslurs.pro} top of each page, so */ -/* dviselec will work OK. */ -/* 2.404 */ -/* Allow slur to end on rest, but not start on a rest. Efaults height */ -/* of ending is default height of start (before any automatic or user- */ -/* defined djustments). User may adjust height as normal from default. */ -/* 2.403 */ -/* Bugfix: turn off repeated beaming patterns.at end of non-last voice. */ -/* 2.402 */ -/* Automatic repeated forced beams. Start with "[:" End with next explicit */ -/* forced beam or end of input block. */ -/* Increase # of forced beams per line of music per input block from 20 to 40 */ -/* 2.401 */ -/* Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. */ -/* Makes 1st part normal shape, and starts 2nd part a little further left. */ -/* Enable arpeggios in xtuplets. Had to make time itar(narp) a real. */ -/* 2.40 */ -/* Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. */ -/* Fix non-ps-slur input to \midslur (third signed integer). Do not reverse */ -/* sign for down-slurs. */ -/* 2.359 */ -/* Add error exit subroutine stop1 to make exit status g77-compatible.. */ -/* Absolute octave on xtup chord note was 2 octave too high, fixed in getnote */ -/* Fermata on vertically shifted rest: special trap in putorn() to set height. */ -/* Correct multiple grace note spacing for small staves (in dograce, */ -/* define wheadpt1 depending on staff size) */ -/* 2.358 */ -/* Allow curvature corrections at start of postscript slur, in dopsslur() */ -/* Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust */ -/* Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] */ -/* Make t[ID] act like s[ID]t, most mods in spsslur(). */ -/* Add spsslur() to read in data for ps slurs, call from getnote. */ -/* In beamstrt, save args for SetupB in common comipb to save them for */ -/* 2nd call when xtup starts with rest */ -/* Add spacing for ornament ")" as if it were accidental, in make2bar(). */ -/* Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() */ -/* Horiz. shift start of ps grace slur, 2 places in dograce(). */ -/* Horiz shift end of grace slur in endslur() */ -/* Make st slurs into postscript ties. Separate subroutine dopsslur(), */ -/* Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) */ -/* Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. */ -/* 2.357a */ -/* Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote */ -/* 2.357 */ -/* Increase dimension for # of lit TeX strings from 52 to 83. */ -/* Allow blank rest in middle of xtuplet. Only mods in g*etnote(). */ -/* 2.356 */ -/* Increased some dimensions from 30 to 40 to allow up to 40 pages. */ -/* In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). */ -/* Fix parsing of "f,h,H,HH" in sslur. */ -/* Fix bug with cdot, note-level for slur termination (in getnote) */ -/* 2.355 */ -/* Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], */ -/* n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues */ -/* Make midi recognize ps ties in doslur. */ -/* Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote */ -/* to get octave right. */ -/* 2.354 */ -/* With postscript slurs, make t-slurs real ties by inserting replacement */ -/* macros \tieforisu, etc, defined in pmx.tex */ -/* Check for open cresc or decresc at end of input block, using list[de]cresc */ -/* Hairpin syntax conditional on postscript slurs. Backup to fill in start */ -/* level, using new backfill(...). Separate height tweaks for */ -/* start and finish. */ -/* 2.353 */ -/* K-0+n to transpose by half step (rather than just change key) */ -/* Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of */ -/* \mbrest's */ -/* Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end */ -/* of input block before movement break, and at start of block after */ -/* movement break, using \newmovement rather than \setzalaligne, since */ -/* former already redefines \stoppiece. In second case, set rptfg2='z'. */ -/* Make clefq(nm) common between pmxb and getnote; change references in */ -/* getnote at 'M' to array elements, setting all new clefs as you go. */ -/* 2.352 */ -/* Remove \parskip redefinition from pmx.tex; write it into TeX file when */ -/* "Ae" is invoked. */ -/* Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine */ -/* \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', */ -/* translate them thru mapping to (1,4,5,6) as \midslur params, then let */ -/* \psforts translate them back to ps slur macors. */ -/* 2.351 */ -/* Number slurs from 0 up instead of 11 down, anticipating postscript slurs. */ -/* Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. */ -/* Increase length of basenameq to 44 characters everywhere. */ -/* Increase dimension of mcpitch (midi-chord-pitch) to 20. */ -/* Set default systems per page to 1 if nv>7 */ -/* In pmxb, move place where isystpg is reset to 0, so that \eject gets */ -/* written when there is just one system per page. */ -/* 2.35 */ -/* Cautionary accidentals with 'c' anywhere in note symbol. */ -/* NEW pmx.tex with \resetsize to set size to normal or small depending on */ -/* current \internote. Used with new coding in dograce() to get right */ -/* new size in case user has \setsize'ed some lines to \smallvalue. For */ -/* \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. */ -/* Affects pmx.tex. */ -/* Continuation figure with fractional length. May now mix with other figures. */ -/* If another figure follow Cont-fig, separate with colon. */ -/* 2.342 */ -/* Bugfix in getnote to recognize relative octave shift in grace at start of */ -/* input block. */ -/* In make2bar, initialize islhgt=0 earlier than before (possible solution */ -/* to Suse g77 compile problem that I could not reproduce).. */ -/* Bugfix in beamstrt & beamn1 for r2x6 c4D d d d */ -/* 2.341 */ -/* Syntax check: Forced page break page number must be > than previous. */ -/* Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. */ -/* 2.34 */ -/* New pmx.tex with redefined liftpausc */ -/* Bug fix with dotted, non-beamed xtups. */ -/* 2.332 */ -/* Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. */ -/* Allow arbitrary pos. input to W in g1etnote and getnote. */ -/* 2.331 */ -/* Bug-fix in dodyn(..): typo on length of arg of txtdyn */ -/* 2.33 */ -/* Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() */ -/* 2.321 */ -/* Rescale accidental shifts. Still use 7 bits but now map (0,127) */ -/* onto (-1.,5.35) */ -/* Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups */ -/* 2.32 (Noticed after posting) */ -/* Prohibit "/" as figure. */ -/* 2.32 (Posted) */ -/* Tidied up accidentals in chords, do spacing. */ -/* Still to do: */ -/* check for "(" on chord notes in spacing algo */ -/* small accids */ -/* double accids */ -/* autoshift slurs */ -/* 2.310 */ -/* Extra call to precrd ahead of spacing chk, and single-note crd/acc */ -/* shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. */ -/* 2.309 */ -/* Alternate algo for accid shifts in chords. */ -/* 2.308 */ -/* Auto horiz. notehead shifting added to precrd. */ -/* 2.307 */ -/* Auto shifting of multiple accidentals in chords. */ -/* "Ao" in main chord note to keep accidentals in order. Set nacc(28). */ -/* If there are any manual main or chord note shifts, then */ -/* If any manual shift is preceded by "A" then */ -/* 1. Auto-shifting proceeds */ -/* 2. "A"-shifts add to autoshifts */ -/* 3. non-"A" shifts are ignored! */ -/* Else (>0 man shifts, none has "A") */ -/* No auto-ordering, No autoshifts, */ -/* End if */ -/* End if */ -/* 2.306 */ -/* Initialize legacy note level to middle C in case user forgets to set */ -/* octave. */ -/* Shift xtup note? */ -/* Shift in elemskips rather than noteheads? */ -/* 2.305 */ -/* Stop pmxb from multiple endvolta's at start of new page. */ -/* 2.304 */ -/* "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on */ -/* for multiple notes in the voice, "S:" last shortened note. */ -/* 2.303 */ -/* vshrink stuff all OK? Description is in pmxb. */ -/* 2.302 */ -/* Toggle vshrink with "Av". vshrink normally kicks in when \interstaff */ -/* hits 20. This still needs work. */ -/* Add " /" to last line if last char is not % or /. */ -/* 2.301 */ -/* Check in beamn1 for single note before multiplicity down-up. */ -/* allow '.PMX' as well as '.pmx' */ -/* 2.299 */ -/* Correct typo in pmxb involving PMXbarnotrue. */ -/* Replacement printed number for xtup: Unsigned integer after 'n' after 'x' */ -/* Minor upgrade parsing xtuplet options 'x...' */ -/* Correct dimension of nxtinbm in make2bar. */ -/* 2.298 */ -/* Account for doubled xtup notes in subroutine getx (user-defined spaces), */ -/* by adding ndoub as an argument.. */ -/* 2.297 */ -/* Created and solved compiler problem. Put drawbm(NM) in its own common. */ -/* Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar */ -/* when \centerbar is used. */ -/* Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX */ -/* use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. */ -/* 2.296 */ -/* Correct printed numbers for forced beams with multiple xtups. For each beam */ -/* make list in setupb by voice of eloff (h-offset) and mtupv (printed #) */ -/* Increase lengths of jobname and infileq by 20 characters */ -/* Enable whole notes and breves as 1st or last note of xtup in beamn1 and */ -/* beamend, and wholes in beamid. */ -/* 2.295 */ -/* Midi balance Ib[n1]:[n2]:...[nn] */ -/* Single-slope beam groups [...]-[...] */ -/* Trap "i" unless after accidental (main notes, xtups, chord notes) */ -/* 2.294 */ -/* Unequal xtups with "D" to double a note in an xtup. */ -/* As above, "F" will (a) increase multiplicity by 1 for marked note and next */ -/* one and (b) add a dot to the first one. */ -/* Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on */ -/* when "." is encountered, then correcting beam start time.(end of getnote) */ -/* MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... */ -/* 2.293 */ -/* Check for single notes spanning bar lines. */ -/* Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup */ -/* must be set in make2bar since beamstrt is not called, fixing problem with */ -/* dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix */ -/* problem when >2 staves. */ -/* Add nodur to args of dodyn, so can check if stemless and avoid height tweak */ -/* Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak */ -/* 2.292a */ -/* Undo syntax check for Type 2 or 3 TeX string starting in column 1. */ -/* Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! */ -/* 2.292 */ -/* Allow comments in xtuplets */ -/* Enable multiple octave jumps in grace notes. */ -/* Allow dynamics in xtuplets. */ -/* Fix bug in getdyn searching for end of text string (correct length of lineq */ -/* to 128) */ -/* Fix bug in dodyn, must ignore horiz. interaction tweak for */ -/* user-text (idno = 0) */ -/* Syntax check for Type 2 or 3 TeX string starting in column 1 */ -/* (NOTE: later undone!) */ -/* Syntax check for page number > npages at forced line break. */ -/* 2.291 */ -/* Fix error in AS command (accid spacing for small systems), making only */ -/* one spec per staff, nv total. */ -/* Stop using MIDI channel 10 */ -/* 2.29 */ -/* Fix error in console output format for # of bytes used in MIDI file. */ -/* Fix bug in dograce so no space is added between grace and main note when */ -/* there is a MIDI-only accidental. */ -/* Fix bug so oes?+4 works. It was too ugly to explain. */ -/* ...Different ways of storing accidental specs on input and output. */ -/* No longer zap \writezbarno in special situations. */ -/* Fix bug in dyntxt level on rest */ -/* Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. */ -/* Activate with Ae. (Maybe later could input alternate values for */ -/* \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 */ -/* in the page, and \endeq on 1st note of next-to-last line in page. */ -/* 2.28 */ -/* Flip direction of forced beam "[f..." */ -/* Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) */ -/* Fix bug in sliding ip's for txtdyn's */ -/* In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) */ -/* 2.27 */ -/* Comment out lines in dodyn checking number of dynamic marks found. Voice */ -/* order may not be monotonic if two lines on a staff. */ -/* Literal dynamic: D"[text]" */ -/* 2.26 */ -/* Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, */ -/* increasing dimension of idynn to 4 to allow 4 symbols on same note. */ -/* Increase voltxtq length from 10 to 20. */ -/* AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough */ -/* accounting for ast's is done by defining effective headwidth */ -/* whead1 in makebar2 to be 0.8*whead. */ -/* 2.25 */ -/* Fix logic bug with sepsym's when # of instruments changes. */ -/* Slight increases in default offsets for hairpin starts after "p" */ -/* 2.24 */ -/* Hairpins D< or D> as toggle. */ -/* Many automatic position tweaks for letter-group dynamics and hairpins. */ -/* 2.23 */ -/* Continued rhythmic shortcuts: space followed by "." or "," */ -/* 2.22 */ -/* In call to doslur, change tno(...) to tnote(...). This was only */ -/* used when checking to slurs per stem directions, and should have been */ -/* the note duration all along. */ -/* MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. */ -/* Use "i" anywhere in note symbol. */ -/* 2.21 */ -/* Increase from 20 to 30 dimensions for movement breaks and midi sections. */ -/* Fix out-of-order declarations per mutex comments */ -/* Add "Bad error" and "Kluging" messages to log file. */ -/* 2.197 */ -/* add /comips/ to save tie-check midi variables */ -/* For spacing of clef changes at start of input block, changed integer time */ -/* lastnodur to prevtn, so it works with xtups. Possible incompatibility! */ -/* 2.196 */ -/* Fix Ickbug with time check in ncmid() */ -/* Interchange \fermataup7 and \pausec to get proper alignment */ -/* Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. */ -/* Add defn's of \hsp, \hspp to pmx.tex */ -/* Fix pre-slurs on xtup chord notes. */ -/* Fixed raised PAuse, define \liftPAuse */ -/* Replace \zbreve\sk with \breve. */ -/* Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what */ -/* about "o" and 1 as shorthand for 16???? Search for "Kluge" */ -/* Added "vo" (voice) as MIDI instrument 55 */ -/* Allow 3-digit page numbers (search for "toppageno") */ -/* Fix bug caused by prior fix (cancelling accid after bar line was ignored). */ -/* Fix double accids in chords */ -/* 2.194 */ -/* Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if */ -/* block. */ -/* Add meter to MIDI file with every pause */ -/* Purify FORTRAN? */ -/* 2.193 */ -/* Increased # of in-line TeX strings from 36 to 52. */ -/* Fix entry of # of bytes in header of tempo/meter/key track to allow >255. */ -/* 2.191 */ -/* Event track: Tempos, meters, keys all together. Data in comevent */ -/* 2.15 */ -/* Pretty good midi capability. Still no attention to slurs on chord notes. */ -/* 2.11 */ -/* 11 Dec 99 c rm1 */ -/* 11 Dec 99 "oes?", "oe?" */ -/* 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes */ -/* 11 Dec 99 Error message for shifted, repeated ornaments. */ -/* 2.10 (Version 2.1) */ -/* Fix bug with lowdot and xtuplets */ -/* 2.09 */ -/* Fix bug with multiple ornament heights over beams, when one is . or _ */ -/* Error message from pmxa if rest on last note of xtup. */ -/* Enable 12 slurs. */ -/* Reinstate multiple rests at start of xtup. */ -/* 2.07 */ -/* Combine consecutive type-1 TeX strings. */ -/* \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. */ -/* Fixed breve chord notes in docrd */ -/* Check irest(28) as well as vxtup when setting nodur for chord notes, since */ -/* vxtup isn't set until 1st *main* note in xtup */ -/* Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. */ -/* 2.06+ */ -/* Make deterministic the beam slope calculation when there are an even # of */ -/* slopes in list and middle two are equal magnitude but opposite sign. */ -/* pmxa Trap for "o:" before 1st note in block */ -/* Partial bug fix for 64th notes in xtuplets. */ -/* Make ixrest a vector, since with new time scheme may not finish xtup in */ -/* same notes block. */ -/* Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) */ -/* 2.06 */ -/* Account for changes in nv when computing \interstaff. Add a counter */ -/* nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever */ -/* setting isysflb(iflb). Note nv can only change at a forced line break. */ -/* Note also, iflb starts at 0! */ -/* 2.05 */ -/* Automatic start of new notes group with part 2 of staff-jump beam */ -/* In make1bar, set irest bit 29 of lowest-voice note at same time, */ -/* use as flag when making notes groups. */ -/* For now, remove dummy blank line at end...it zaps terminal repeats. */ -/* 2.02 */ -/* Fixed slur-counting bug for multiple, slurred, aftergraces. */ -/* 2.01 */ -/* Increase to ask(1400) */ -/* Increase max forced page breaks to 18 */ -/* Define pausc for centered pause */ -/* 2.0a */ -/* Insert dummy blank line at very end to handle input files w/o terminal CR-LF */ -/* pmx03r */ -/* Option m[n] in S symbol to change musicsize (for parts) */ -/* Double dotted rests now work. */ -/* Write file name to log file */ -/* Check existence of input file */ -/* Allow 24-char jobname, may end with ".pmx" */ -/* Comment out time stuff */ -/* Replace 3-argument getarg with 2-argument + iargc */ -/* Fix bug with negative noinst due to nint<=int replacement */ -/* move lovation of iv in isdat1 to allow iv>7. */ -/* Set nm=12 */ -/* pmx03q */ -/* replace int(x+.001) with nint(x) */ -/* Write TeX file name to screen and to pml. */ -/* Replace char(...) with chax(...) to sovle msdev bug. */ -/* Bug fix: macro terminations when M is on a line by itself. */ -/* Bug fix: don't accumulate space for XS in pmxa. */ -/* Streamline Macros: use pointers to bufq instead of scratch files */ -/* pmx03p */ -/* Store input file in single character array bufq. */ -/* lbuf(i)*2 is length of line i */ -/* ipbuf is position just before next line to be read. */ -/* pmx03 */ -/* Optimize read/writes */ -/* pmx02 */ -/* Fix line count (for errors) when there are saved macros */ -/* pmx01 */ -/* In optimize mode, open/close macros (Watch out for residual zz files!) */ -/* Command line input */ -/* Option Ao to optimize, otherwise normal processing */ - -/* cccccc */ - -/* immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing */ -/* nmidsec section starts and stops based on PLAYING macros (not recording). */ - -/* cccccccccccccccccccccccc */ - - -/* cccccccccccccccccccccccc */ -/* itstart = mytime() */ - s_copy(comver_1.versionc, version, (ftnlen)5, (ftnlen)5); - -/* Initialize midi parameters */ - - commmac_1.gottempo = FALSE_; - commidi_1.ismidi = FALSE_; - commidi_1.debugmidi = FALSE_; - commidi_1.relacc = FALSE_; - commmac_1.mmacrec = FALSE_; - commmac_1.nmidsec = 1; - commidi_1.mgap = 10; - comevent_1.miditime = 0; - comevent_1.lasttime = 0; - commidi_1.nmidcrd = 0; - comslm_1.nusebl = 0; - commidi_1.notmain = FALSE_; - for (ivx = 1; ivx <= 24; ++ivx) { - commidi_1.twoline[ivx - 1] = FALSE_; - commidi_1.midinst[ivx - 1] = 6; - commvel_1.midivel[ivx - 1] = 127; - commvel_1.midibal[ivx - 1] = 64; - commvel_1.miditran[ivx - 1] = 0; -/* L3: */ - } - for (icm = 0; icm <= 24; ++icm) { - commidi_1.imidi[icm] = 0; - commidi_1.restpend[icm] = FALSE_; - commidi_1.trest[icm] = 0.f; - comslm_1.levson[icm] = 0; - comslm_1.levsoff[icm] = 0; - comslm_1.slmon[icm] = FALSE_; - comslm_1.naccbl[icm] = 0; - comdiag_1.n69[icm] = 0; - comdiag_1.n34[icm] = 0; - commmac_1.msecstrt[icm] = 1; -/* L12: */ - } - -/* End of midi parameter initialization */ - - commus_1.musize = 0; - optimize = FALSE_; - numargs = iargc_(); - if (numargs == 0) { - s_wsle(&io___10); - do_lio(&c__9, &c__1, "You could have entered a jobname on the comman" - "d line,", (ftnlen)53); - e_wsle(); - s_wsle(&io___11); - do_lio(&c__9, &c__1, " but you may enter one now:", (ftnlen)32); - e_wsle(); - s_rsfe(&io___12); - do_fio(&c__1, jobname, (ftnlen)44); - e_rsfe(); - numargs = 1; - } else { -/* call getarg(1,jobname,idum) ! May need to replace this w/ next line */ - getarg_(&c__1, jobname, (ftnlen)44); - } -L10: - ljob = lenstr_(jobname, &c__44, (ftnlen)44); - if (ljob > 44) { - s_wsle(&io___15); - do_lio(&c__9, &c__1, "Jobname is too long. Try again.", (ftnlen)31); - e_wsle(); - stop1_(); - } else if (ljob == 0) { - s_wsle(&io___16); - do_lio(&c__9, &c__1, "No was jobname entered. Try again.", (ftnlen)34) - ; - e_wsle(); - stop1_(); - } else if (numargs == 2) { - if (ljob == 2 && s_cmp(jobname, "-o", (ftnlen)2, (ftnlen)2) == 0) { - optimize = TRUE_; -/* call getarg(2,jobname,idum) ! May need to replace this w/ next line */ - getarg_(&c__2, jobname, (ftnlen)44); - numargs = 1; - goto L10; - } else { - s_wsle(&io___17); - do_lio(&c__9, &c__1, "Illegal option on command line", (ftnlen)30) - ; - e_wsle(); - stop1_(); - } - } - -/* Strip ".pmx" if necessary */ - -/* Computing MAX */ - i__1 = i_indx(jobname, ".pmx", (ftnlen)44, (ftnlen)4), i__2 = i_indx( - jobname, ".PMX", (ftnlen)44, (ftnlen)4); - ndxpmx = max(i__1,i__2); - if (ndxpmx > 0) { - s_copy(jobname, jobname, (ftnlen)44, ndxpmx - 1); - ljob += -4; - } - -/* Check for existence of input file */ - -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".pmx"; - s_cat(infileq, a__1, i__3, &c__2, (ftnlen)47); - ioin__1.inerr = 0; - ioin__1.infilen = 47; - ioin__1.infile = infileq; - ioin__1.inex = &fexist; - ioin__1.inopen = 0; - ioin__1.innum = 0; - ioin__1.innamed = 0; - ioin__1.inname = 0; - ioin__1.inacc = 0; - ioin__1.inseq = 0; - ioin__1.indir = 0; - ioin__1.infmt = 0; - ioin__1.inform = 0; - ioin__1.inunf = 0; - ioin__1.inrecl = 0; - ioin__1.innrec = 0; - ioin__1.inblank = 0; - f_inqu(&ioin__1); - if (! fexist) { - ioin__1.inerr = 0; - ioin__1.infilen = ljob + 4; -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".PMX"; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); - ioin__1.infile = ch__1; - ioin__1.inex = &fexist; - ioin__1.inopen = 0; - ioin__1.innum = 0; - ioin__1.innamed = 0; - ioin__1.inname = 0; - ioin__1.inacc = 0; - ioin__1.inseq = 0; - ioin__1.indir = 0; - ioin__1.infmt = 0; - ioin__1.inform = 0; - ioin__1.inunf = 0; - ioin__1.inrecl = 0; - ioin__1.innrec = 0; - ioin__1.inblank = 0; - f_inqu(&ioin__1); - if (! fexist) { - s_wsle(&io___21); -/* Writing concatenation */ - i__3[0] = 17, a__1[0] = "Cannot find file "; - i__3[1] = 47, a__1[1] = infileq; - s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)64); - do_lio(&c__9, &c__1, ch__2, (ftnlen)64); - e_wsle(); - stop1_(); - } else { -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".PMX"; - s_cat(infileq, a__1, i__3, &c__2, (ftnlen)47); - } - } - -/* Open a log file */ - - o__1.oerr = 0; - o__1.ounit = 15; - o__1.ofnmlen = ljob + 4; -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".pml"; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); - o__1.ofnm = ch__1; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); -/* Writing concatenation */ - i__4[0] = 21, a__2[0] = "This is PMX, Version "; - i__4[1] = 5, a__2[1] = version; - i__4[2] = 2, a__2[2] = ", "; - i__4[3] = 9, a__2[3] = date; - s_cat(ch__3, a__2, i__4, &c__4, (ftnlen)37); - printl_(ch__3, (ftnlen)37); - ljob4 = ljob; -/* Writing concatenation */ - i__3[0] = 8, a__1[0] = "Opening "; - i__3[1] = 47, a__1[1] = infileq; - s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)55); - printl_(ch__4, (ftnlen)55); - o__1.oerr = 0; - o__1.ounit = 18; - o__1.ofnmlen = 47; - o__1.ofnm = infileq; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); - -/* Copy input file into common buffer */ - - inbuff_1.ipbuf = 0; - truelinecount_1.linewcom[0] = 1; - for (inbuff_1.ilbuf = 1; inbuff_1.ilbuf <= 4000; ++inbuff_1.ilbuf) { - ncomments = 0; -L14: - i__1 = s_rsfe(&io___24); - if (i__1 != 0) { - goto L9; - } - i__1 = do_fio(&c__1, lnholdq, (ftnlen)128); - if (i__1 != 0) { - goto L9; - } - i__1 = e_rsfe(); - if (i__1 != 0) { - goto L9; - } - inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) lenstr_(lnholdq, & - c__128, (ftnlen)128); - if (inbuff_1.lbuf[inbuff_1.ilbuf - 1] == 0) { - -/* Blank line. Make it a single blank with length 1 */ - - inbuff_1.lbuf[inbuff_1.ilbuf - 1] = 1; - s_copy(lnholdq, " ", (ftnlen)128, (ftnlen)1); - } - -/* Now line has at least one non blank character. Check for comment */ -/* As of Version 260, do not copy comments into bufq */ -/* But need to count %'s for error messaging */ -/* if (lnholdq(1:1).eq.'%') go to 14 */ - if (*(unsigned char *)lnholdq == '%') { - ++ncomments; - goto L14; - } - -/* When here, have counted all preceding comments and have a real line */ - - if (inbuff_1.ilbuf > 1) { - truelinecount_1.linewcom[inbuff_1.ilbuf - 1] = - truelinecount_1.linewcom[inbuff_1.ilbuf - 2] + 1 + - ncomments; - } else { - truelinecount_1.linewcom[0] = ncomments + 1; - } - if (inbuff_1.ipbuf + inbuff_1.lbuf[inbuff_1.ilbuf - 1] > 65536) { - s_wsle(&io___26); - do_lio(&c__9, &c__1, "Too many characters in file, stopping", ( - ftnlen)37); - e_wsle(); - stop1_(); - } - i__1 = inbuff_1.ipbuf; - s_copy(inbuff_1.bufq + i__1, lnholdq, inbuff_1.ipbuf + inbuff_1.lbuf[ - inbuff_1.ilbuf - 1] - i__1, (ftnlen)128); - inbuff_1.ipbuf += inbuff_1.lbuf[inbuff_1.ilbuf - 1]; -/* L8: */ - } - printl_("Too many lines in input file", (ftnlen)28); - stop1_(); -L9: - -/* Insert dummy line to handle input files w/o CR-LF at end. */ - - inbuff_1.nlbuf = inbuff_1.ilbuf - 1; -/* nlbuf = ilbuf */ -/* bufq(ipbuf+1:ipbuf+3) = ' / ' */ -/* lbuf(nlbuf) = 3 */ - cl__1.cerr = 0; - cl__1.cunit = 18; - cl__1.csta = 0; - f_clos(&cl__1); - i__1 = maxit; - for (numit = 1; numit <= i__1; ++numit) { - if (optimize) { - printl_("Starting an iteration", (ftnlen)21); - } - -/* When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. */ -/* Otherwise, nbars0 is the input */ -/* When islast=.false., pmxb only returns poe's, otherwise does whole job */ - - pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars0, &optimize, (ftnlen) - 44); - if (! optimize) { - if (commidi_1.ismidi) { - -/* Set up channel numbers for midi. */ - - commidi_1.numchan = 0; - for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) { - if (commidi_1.twoline[a1ll_1.iv - 1]) { - commidi_1.midchan[a1ll_1.iv + 23] = commidi_1.numchan; - ++commidi_1.numchan; - } - commidi_1.midchan[a1ll_1.iv - 1] = commidi_1.numchan; - ++commidi_1.numchan; -/* L11: */ - } - -/* numchan will now be the number of channels, but max channel # is numchan-1 */ - -/* Set up velocities, balances, and midi-transpositions */ - - for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) { - if (commidi_1.twoline[a1ll_1.iv - 1]) { - commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv + 23]] = - commvel_1.midivel[a1ll_1.iv - 1]; - commvel_1.midbc[commidi_1.midchan[a1ll_1.iv + 23]] = - commvel_1.midibal[a1ll_1.iv - 1]; - commvel_1.midtc[commidi_1.midchan[a1ll_1.iv + 23]] = - commvel_1.miditran[a1ll_1.iv - 1]; - } - commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv - 1]] = - commvel_1.midivel[a1ll_1.iv - 1]; - commvel_1.midbc[commidi_1.midchan[a1ll_1.iv - 1]] = - commvel_1.midibal[a1ll_1.iv - 1]; - commvel_1.midtc[commidi_1.midchan[a1ll_1.iv - 1]] = - commvel_1.miditran[a1ll_1.iv - 1]; -/* L13: */ - } - } - -/* TEMPORARY!!! */ - - s_wsle(&io___30); - do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7); - do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof( - integer)); - e_wsle(); - ip1 = 1; - i__2 = inbuff_1.nlbuf; - for (ilb = 1; ilb <= i__2; ++ilb) { -/* write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), */ -/* * bufq(ip1:ip1+lbuf(ilb)-1), */ -/* * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), */ -/* * k=min(3,lbuf(ilb)),1,-1) */ - ip1 += inbuff_1.lbuf[ilb - 1]; -/* L10000: */ - } - iplast = ip1 - 1; - -/* Check to see if (1) last line is "/" and (2) next to last */ -/* line is "/" */ - -/* print*,'iplast:',iplast */ -/* print*,'Last line:' */ -/* print*,bufq(iplast+1-lbuf(nlbuf):iplast) */ -/* print*,'Last char of next to last line:' */ -/* print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) */ - i__2 = iplast + 1 - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1; - if (s_cmp(inbuff_1.bufq + i__2, " /", iplast - i__2, (ftnlen)3) - == 0) { - i__2 = iplast - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1; - if (s_cmp(inbuff_1.bufq + i__2, "/", iplast - inbuff_1.lbuf[ - inbuff_1.nlbuf - 1] - i__2, (ftnlen)1) == 0) { - s_wsle(&io___34); - do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39); - e_wsle(); - s_wsle(&io___35); - do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39); - e_wsle(); - --inbuff_1.nlbuf; - } - } - - pmxb_(&c_true, poe0, &ncalls, &optimize); - if (commidi_1.ismidi) { - -/* Write midi file */ - - o__1.oerr = 0; - o__1.ounit = 51; - o__1.ofnmlen = ljob + 4; -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".mid"; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); - o__1.ofnm = ch__1; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); - if (commidi_1.debugmidi) { - o__1.oerr = 0; - o__1.ounit = 52; - o__1.ofnmlen = ljob + 4; -/* Writing concatenation */ - i__3[0] = ljob, a__1[0] = jobname; - i__3[1] = 4, a__1[1] = ".dbm"; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); - o__1.ofnm = ch__1; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); - } - printl_(" ", (ftnlen)1); -/* Writing concatenation */ - i__5[0] = 8, a__3[0] = "Writing "; - i__5[1] = ljob, a__3[1] = jobname; - i__5[2] = 4, a__3[2] = ".mid"; - s_cat(ch__5, a__3, i__5, &c__3, (ftnlen)56); - printl_(ch__5, ljob + 12); - writemidi_(jobname, &ljob, (ftnlen)44); - } - cl__1.cerr = 0; - cl__1.cunit = 15; - cl__1.csta = 0; - f_clos(&cl__1); - s_stop("", (ftnlen)0); - } - s_wsle(&io___37); - do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7); - do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof(integer)) - ; - e_wsle(); - ip1 = 1; - pmxb_(&c_false, poe0, &ncalls, &optimize); - poestats_(&nsyst, poe0, &poebar0, &devnorm0); - -/* Save initial deviation and line breaks for later comparison */ - - if (numit == 1) { - devpmx = devnorm0; - i__2 = nsyst; - for (isys = 1; isys <= i__2; ++isys) { - nbari[isys - 1] = nbars0[isys - 1]; -/* L20: */ - } - } - sortpoe_(&nsyst, poe0, ipoe); - for (iupord = nsyst; iupord >= 1; --iupord) { - isysu = ipoe[iupord - 1]; - s_wsle(&io___46); - do_lio(&c__9, &c__1, "isysu=", (ftnlen)6); - do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer)); - e_wsle(); - s_wsle(&io___47); - do_lio(&c__9, &c__1, "isysu=", (ftnlen)6); - do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer)); - e_wsle(); - -/* Skip if system isysu has poe0 < avg or isysd has poe0 > avg */ - - if (poe0[isysu - 1] < poebar0) { - goto L1; - } - i__2 = nsyst; - for (idnord = 1; idnord <= i__2; ++idnord) { - isysd = ipoe[idnord - 1]; - if (isysu == isysd || nbars0[isysd - 1] == 1 || poe0[isysd - - 1] > poebar0) { - goto L5; - } - i__6 = nsyst; - for (isyst = 1; isyst <= i__6; ++isyst) { - nbars[isyst - 1] = nbars0[isyst - 1]; - if (isyst == isysu) { - ++nbars[isyst - 1]; - } else if (isyst == isysd) { - --nbars[isyst - 1]; - } -/* L2: */ - } - pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars, &optimize, ( - ftnlen)44); - pmxb_(&c_false, poe, &ncalls, &optimize); - poestats_(&nsyst, poe, &poebar, &devnorm); - if (devnorm < devnorm0) { - devnorm0 = devnorm; - poebar0 = poebar; - i__6 = nsyst; - for (isys = 1; isys <= i__6; ++isys) { - nbars0[isys - 1] = nbars[isys - 1]; - poe0[isys - 1] = poe[isys - 1]; -/* L4: */ - } - s_wsle(&io___55); - do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", ( - ftnlen)32); - do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof( - integer)); - do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof( - integer)); - do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof( - real)); - e_wsle(); - s_wsle(&io___56); - do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", ( - ftnlen)32); - do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof( - integer)); - do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof( - integer)); - do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof( - real)); - e_wsle(); - s_wsfe(&io___57); - i__6 = nsyst; - for (isys = 1; isys <= i__6; ++isys) { - do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen) - sizeof(integer)); - } - e_wsfe(); - s_wsfe(&io___58); - i__6 = nsyst; - for (isys = 1; isys <= i__6; ++isys) { - do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen) - sizeof(integer)); - } - e_wsfe(); - sortpoe_(&nsyst, poe0, ipoe); - goto L6; - } -L5: - ; - } -L1: - ; - } - -/* If we get here, must have gone thru all switches and found nothing better, */ -/* so done! */ - - goto L7; -L6: - ; - } -L7: - s_wsle(&io___59); - do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23); - do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer)); - do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10); - do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer)); - e_wsle(); - s_wsle(&io___60); - do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23); - do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer)); - do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10); - do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer)); - e_wsle(); - s_wsle(&io___61); - do_lio(&c__9, &c__1, "Final error:", (ftnlen)12); - do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real)); - do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16); - do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real)); - e_wsle(); - s_wsle(&io___62); - do_lio(&c__9, &c__1, "Final error:", (ftnlen)12); - do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real)); - do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16); - do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real)); - e_wsle(); - s_wsle(&io___63); - do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23); - r__1 = (1 - devnorm0 / devpmx) * 100.f; - do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real)); - e_wsle(); - s_wsle(&io___64); - do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23); - r__1 = (1 - devnorm0 / devpmx) * 100.f; - do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real)); - e_wsle(); - printl_("Initial bars/system:", (ftnlen)20); - s_wsfe(&io___65); - i__1 = nsyst; - for (isys = 1; isys <= i__1; ++isys) { - do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer)); - } - e_wsfe(); - s_wsfe(&io___66); - i__1 = nsyst; - for (isys = 1; isys <= i__1; ++isys) { - do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer)); - } - e_wsfe(); - printl_("Final bars/system:", (ftnlen)18); - s_wsfe(&io___67); - i__1 = nsyst; - for (isys = 1; isys <= i__1; ++isys) { - do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer)); - } - e_wsfe(); - s_wsfe(&io___68); - i__1 = nsyst; - for (isys = 1; isys <= i__1; ++isys) { - do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer)); - } - e_wsfe(); - pmxa_(jobname, &ljob4, &c_false, &nsyst, nbars0, &optimize, (ftnlen)44); - pmxb_(&c_true, poe0, &ncalls, &optimize); -/* itend = mytime() */ -/* print*,'Elapsed time in ms:',itend-itstart */ -/* write(15,*)'Elapsed time in ms:',itend-itstart */ - cl__1.cerr = 0; - cl__1.cunit = 15; - cl__1.csta = 0; - f_clos(&cl__1); - return 0; -} /* MAIN__ */ - -/* Subroutine */ int accsym_(integer *nacc, char *acsymq, integer *lacc, - ftnlen acsymq_len) -{ - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - - /* Local variables */ - static integer iacc; - - /* Fortran I/O blocks */ - static cilist io___70 = { 0, 6, 0, 0, 0 }; - - - iacc = *nacc & 7; - if (iacc == 1) { - s_copy(acsymq, "fl", (ftnlen)3, (ftnlen)2); - *lacc = 2; - } else if (iacc == 2) { - s_copy(acsymq, "sh", (ftnlen)3, (ftnlen)2); - *lacc = 2; - } else if (iacc == 3) { - s_copy(acsymq, "na", (ftnlen)3, (ftnlen)2); - *lacc = 2; - } else if (iacc == 5) { - s_copy(acsymq, "dfl", (ftnlen)3, (ftnlen)3); - *lacc = 3; - } else if (iacc == 6) { - s_copy(acsymq, "dsh", (ftnlen)3, (ftnlen)3); - *lacc = 3; - } else { - s_wsle(&io___70); - do_lio(&c__9, &c__1, "bad accidental: ", (ftnlen)16); - do_lio(&c__3, &c__1, (char *)&iacc, (ftnlen)sizeof(integer)); - e_wsle(); - } - return 0; -} /* accsym_ */ - -/* Subroutine */ int addask_(real *taskn, real *waskn, real *elaskn, real * - fixednew, real *scaldold, real *tglp1, logical *isudsp) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - - /* Local variables */ - extern /* Subroutine */ int stop1_(void); - static integer iudsp; - - /* Fortran I/O blocks */ - static cilist io___72 = { 0, 6, 0, 0, 0 }; - - - if (*isudsp) { - -/* Find which udsp we're dealing with */ - - i__1 = comudsp_1.nudsp; - for (iudsp = 1; iudsp <= i__1; ++iudsp) { - if ((r__1 = *taskn + *tglp1 - comudsp_1.tudsp[iudsp - 1], dabs( - r__1)) < comtol_1.tol) { - goto L2; - } -/* L1: */ - } - s_wsle(&io___72); - do_lio(&c__9, &c__1, "You should note BEEE here in addask!", (ftnlen) - 36); - e_wsle(); - stop1_(); -L2: - -/* Fixednew and scaldold must not be changed, since udsp's are already included */ -/* in fsyst from pmxa, and udsp don't involve scaled space.. */ - - if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1, - comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) { - -/* Must add user-defined space to what's there already. */ - - comas1_1.wask[comas1_1.naskb - 1] += comudsp_1.udsp[iudsp - 1]; - } else { - -/* This place has no other space. */ - - ++comas1_1.naskb; - comas1_1.task[comas1_1.naskb - 1] = *taskn; - comas1_1.wask[comas1_1.naskb - 1] = comudsp_1.udsp[iudsp - 1]; - comas1_1.elask[comas1_1.naskb - 1] = 0.f; - } - } else { - -/* This is a normal space, no effect if smaller than existing space */ - - if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1, - comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) { - -/* We already put in some space at this time */ -/* Check if new one needs more space than old one at same time */ - - if (*waskn > comas1_1.wask[comas1_1.naskb - 1]) { - --comas1_1.naskb; - } else { - return 0; - } - } - ++comas1_1.naskb; - comas1_1.task[comas1_1.naskb - 1] = *taskn; - comas1_1.wask[comas1_1.naskb - 1] = *waskn; - comas1_1.elask[comas1_1.naskb - 1] = *elaskn; - *fixednew += *waskn; - *scaldold += *elaskn; - } - return 0; -} /* addask_ */ - -/* Subroutine */ int addblank_(char *noteq, integer *lnoten, ftnlen noteq_len) -{ - /* System generated locals */ - address a__1[2]; - integer i__1[2]; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, - char **, integer *, integer *, ftnlen); - - /* Local variables */ - static char tchar[1]; - - s_copy(tchar, noteq, (ftnlen)1, (ftnlen)8); -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = " "; - i__1[1] = 1, a__1[1] = tchar; - s_cat(noteq, a__1, i__1, &c__2, (ftnlen)8); - *lnoten = 2; - return 0; -} /* addblank_ */ - -/* Subroutine */ int addfb_(integer *nfb, integer *iv, real *tnew, real *t1fb, - real *t2fb, char *ulfbq, integer *ifbadd, ftnlen ulfbq_len) -{ - static integer ifb; - - /* Parameter adjustments */ - ulfbq -= 25; - t2fb -= 25; - t1fb -= 25; - --nfb; - - /* Function Body */ - *ifbadd = 1; - ++nfb[*iv]; - for (ifb = nfb[*iv] - 1; ifb >= 1; --ifb) { - if (*tnew < t1fb[*iv + ifb * 24] - comtol_1.tol) { - t1fb[*iv + (ifb + 1) * 24] = t1fb[*iv + ifb * 24]; - t2fb[*iv + (ifb + 1) * 24] = t2fb[*iv + ifb * 24]; - *(unsigned char *)&ulfbq[*iv + (ifb + 1) * 24] = *(unsigned char * - )&ulfbq[*iv + ifb * 24]; - } else { - *ifbadd = ifb + 1; - goto L2; - } -/* L1: */ - } -L2: - t1fb[*iv + *ifbadd * 24] = *tnew; - *(unsigned char *)&ulfbq[*iv + *ifbadd * 24] = 'x'; - return 0; -} /* addfb_ */ - - - -/* Subroutine */ int addmidi_(integer *icm, integer *nolev, integer *iacc, - integer *isig, real *time, logical *rest, logical *endrest) -{ - /* Initialized data */ - - static shortint icmm[16] = { 0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16 }; - - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1; - - /* Builtin functions */ - integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, - char *, ftnlen), e_wsle(void), i_indx(char *, char *, ftnlen, - ftnlen); - - /* Local variables */ - static logical it1found; - static integer nsav4tie; - extern /* Subroutine */ int chkimidi_(integer *); - static char notenumq[1]; - static integer i__, j, it1; - extern integer igetvarlen_(shortint *, integer *, integer *, integer *); - static integer it2; - extern integer isetvarlen_(integer *, integer *); - static integer ion; - static shortint itk[25]; - static integer jacc, kacc, macc, ioff, isav, idur, jsav, idur1; - extern /* Subroutine */ int stop1_(void); - static integer imidt, ipsav, ipsav0, nby2on; - extern integer iashft_(integer *); - static integer nbytes; - extern /* Subroutine */ int printl_(char *, ftnlen); - static integer nby2off; - static logical eximacc; - static integer itiesav[500] /* was [5][100] */, idurvar; - - /* Fortran I/O blocks */ - static cilist io___80 = { 0, 6, 0, 0, 0 }; - static cilist io___92 = { 0, 6, 0, 0, 0 }; - - - -/* Following variables are local but must be saved. I hope they are. */ -/* (3/18/00) With g77 they are not, so add a common block here. */ - -/* integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) */ -/* data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ */ - -/* Cancel out barline accidentals if there's a rest. */ - - if (*rest) { - comslm_1.naccbl[(300 + (0 + (*icm - 0 << 2)) - 300) / 4] = 0; - } - -/* Special path to insert dummy rest at end of a section */ - - if (*endrest) { - goto L20; - } - - i__1 = commidi_1.nmidcrd; - for (ion = 0; ion <= i__1; ++ion) { - -/* check if this is only to get pitch of a chord note */ - - if (commidi_1.notmain) { - goto L6; - } - -/* check for rest */ - - if (*rest) { - -/* Will not put in a note, but must update timing */ - - if (! commidi_1.restpend[*icm]) { - -/* First rest in sequence, save the time */ - - commidi_1.restpend[*icm] = TRUE_; - commidi_1.trest[*icm] = *time; - } else { - commidi_1.trest[*icm] += *time; - } - -/* Note: code checkers don't like the above due to calling addmidi(trest(icm)) */ -/* but this only happens if rest at end of section (endrest=.true.) (called */ -/* from getmidi(), in which case these above lines are bypassed. */ - - chkimidi_(icm); - return 0; - } - -/* time tics */ - - if (commidi_1.imidi[*icm] > 0 && ion == 0) { - idur = commidi_1.mgap; - } else { - idur = 0; - } - if (commidi_1.restpend[*icm]) { - commidi_1.restpend[*icm] = FALSE_; - r__1 = commidi_1.trest[*icm] * 15; - idur += i_nint(&r__1); - } - -/* time to start of note */ - - idurvar = isetvarlen_(&idur, &nby2on); - if (nby2on > 4) { - s_wsle(&io___80); - do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.", ( - ftnlen)37); - e_wsle(); - stop1_(); - } - ++commidi_1.imidi[*icm]; - i__2 = nby2on; - for (i__ = 1; i__ <= i__2; ++i__) { - -/* imidi points to cell before highest (leftmost) byte. Start with lowest byte */ -/* at far right, fill in backwards */ - - commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2on - i__) * - 25 - 25] = (shortint) (idurvar % 256); - if (nby2on > 1) { - idurvar /= 256; - } -/* L2: */ - } - commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2on - 1; - -/* Note-on signal */ - - ++commidi_1.imidi[*icm]; -/* mmidi(icm,imidi(icm)) = 9*16+icm */ - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) ( - icmm[*icm] + 144); - -/* Entry point for chord note pitch determination */ - -L6: - -/* Get midi pitch. On chord iteration, only do this first time (main note), */ -/* since pitch was already computed for nonmain chord notes. */ - - if (ion == 0) { - ipsav = *nolev * 12.f / 7 + 11; - ipsav0 = ipsav; - if (*isig != 0) { - -/* Adjust for signature */ - - *(unsigned char *)notenumq = (char) (*nolev % 7 + 48); - if (*isig >= i_indx("4152630", notenumq, (ftnlen)7, (ftnlen)1) - ) { - ++ipsav; - } else if (-(*isig) >= i_indx("0362514", notenumq, (ftnlen)7, - (ftnlen)1)) { - --ipsav; - } - } - -/* Deal with accidentals. */ - -/* iacc 0 1 2 3 4 5 6 7 */ -/* effect X fl sh na X dfl dsh X */ -/* iashft X -1 1 0 X -2 2 X */ - - jacc = 0; - eximacc = FALSE_; - if (*iacc > 0) { - -/* Adjust key-sig-adjusted pitch for explicit accidental (and exit) */ - - jacc = iashft_(iacc); - eximacc = TRUE_; - if (! commidi_1.relacc) { - jacc = jacc + ipsav0 - ipsav; - } - -/* (Above) Shift applies to diatonic pitch but will be added to adjusted one */ - - } else if (commidi_1.naccim[*icm] > 0) { - -/* Possible implicit accidental from earlier in the bar */ -/* Check for prior accid in this bar at this note level */ - - i__2 = commidi_1.naccim[*icm]; - for (kacc = 1; kacc <= i__2; ++kacc) { - if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) { - jacc = commidi_1.jaccim[*icm + kacc * 25 - 25]; - eximacc = TRUE_; - if (! commidi_1.relacc) { - jacc = jacc + ipsav0 - ipsav; - } - goto L4; - } -/* L3: */ - } -L4: - ; - } - -/* Must split off the following if block from those above because chord */ -/* notes can cause naccim>0, forcing us to miss other chord note's */ -/* accross-bar-line accidental */ - - if (comslm_1.naccbl[*icm] > 0 && ! eximacc) { - -/* Possible carryover accid from prior bar (or prior same-pitch note). */ - - i__2 = comslm_1.naccbl[*icm]; - for (kacc = 1; kacc <= i__2; ++kacc) { - if (comslm_1.laccbl[*icm + kacc * 25 - 25] == *nolev) { - jacc = comslm_1.jaccbl[*icm + kacc * 25 - 25]; - -/* Since we are *using* the bar-line accid, must flag it to be saved for next. */ - - ++comslm_1.nusebl; - comips_1.jusebl[comslm_1.nusebl - 1] = (shortint) - jacc; - comips_1.lusebl[comslm_1.nusebl - 1] = (shortint) (* - nolev); - if (! commidi_1.relacc) { - jacc = jacc + ipsav0 - ipsav; - } - goto L22; - } -/* L21: */ - } -L22: - ; - } - ipsav += jacc; - -/* Midi transpositions */ - - ipsav += commvel_1.midtc[*icm]; - } - if (commidi_1.notmain) { - commidi_1.mcpitch[commidi_1.nmidcrd - 1] = ipsav; - -/* Save pitch for tie checks */ - - if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm]) { - comips_1.ipslon[*icm] = (shortint) ipsav; - } - } else { - ++commidi_1.imidi[*icm]; - if (ion == 0) { - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( - shortint) ipsav; - if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm]) - { - comips_1.ipslon[*icm] = (shortint) ipsav; - } - } else { - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( - shortint) commidi_1.mcpitch[ion - 1]; - } - } - if (ion == 0) { - -/* Only record accids for non-chords, main chord note during chord iteration */ -/* and chordnotes on first call but not during iteration */ - - if (*iacc > 0) { - -/* Set marker for accidental for possible continuations later this bar */ -/* but first check and clear earlier ones on same note. */ - - i__2 = commidi_1.naccim[*icm]; - for (kacc = 1; kacc <= i__2; ++kacc) { - if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) { - i__3 = commidi_1.naccim[*icm] - 1; - for (macc = kacc; macc <= i__3; ++macc) { - commidi_1.laccim[*icm + macc * 25 - 25] = - commidi_1.laccim[*icm + (macc + 1) * 25 - - 25]; - commidi_1.jaccim[*icm + macc * 25 - 25] = - commidi_1.jaccim[*icm + (macc + 1) * 25 - - 25]; -/* L24: */ - } - goto L25; - } -/* L23: */ - } - goto L26; -L25: - --commidi_1.naccim[*icm]; -L26: - -/* Flag new accidental */ - - ++commidi_1.naccim[*icm]; - commidi_1.laccim[*icm + commidi_1.naccim[*icm] * 25 - 25] = * - nolev; - commidi_1.jaccim[*icm + commidi_1.naccim[*icm] * 25 - 25] = - iashft_(iacc); - } - -/* Bail if this is a chord note on the first call (from docrd) */ - - if (commidi_1.notmain) { - chkimidi_(icm); - return 0; - } - } - -/* Vel */ - - ++commidi_1.imidi[*icm]; -/* mmidi(icm,imidi(icm)) = 127 */ - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) - commvel_1.midvelc[*icm]; - chkimidi_(icm); -/* L7: */ - } - -/* For tie checks */ - - if (comslm_1.levson[*icm] > 0 && ! comslm_1.slmon[*icm]) { - comslm_1.imidso[*icm] = commidi_1.imidi[*icm]; - } - -/* Entry point for special rests at section ends (endrest=T) */ - -L20: - -/* Now insert all the ends */ - - i__1 = commidi_1.nmidcrd; - for (ioff = 0; ioff <= i__1; ++ioff) { - if (ioff == 0) { - -/* time to end */ - - r__1 = *time * 15; - idur1 = i_nint(&r__1); - r__1 = commidi_1.trest[*icm] * 15; - if (! (*endrest) || comevent_1.miditime == i_nint(&r__1)) { - idur = idur1 - commidi_1.mgap; - } else { - idur = idur1; - } - -/* Deal with roundoff problems with 7-tuplets on half or quarters */ - - if (idur1 == 69) { - ++comdiag_1.n69[*icm]; -/* if (mod(n69(icm)+6,7) .gt. 3) idur = 58 */ - if ((comdiag_1.n69[*icm] + 6) % 7 > 3) { - idur = idur1 - commidi_1.mgap - 1; - } - } else if (idur1 == 34) { - ++comdiag_1.n34[*icm]; - if ((comdiag_1.n34[*icm] + 6) % 7 > 4) { - idur = idur1 - commidi_1.mgap + 1; - } - } - idurvar = isetvarlen_(&idur, &nby2off); - if (nby2off > 4) { - s_wsle(&io___92); - do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.", - (ftnlen)37); - e_wsle(); - stop1_(); - } - ++commidi_1.imidi[*icm]; - chkimidi_(icm); - i__2 = nby2off; - for (i__ = 1; i__ <= i__2; ++i__) { - commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2off - i__) - * 25 - 25] = (shortint) (idurvar % 256); - if (nby2off > 1) { - idurvar /= 256; - } -/* L1: */ - } - commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2off - 1; - } else { - -/* Inserting end of chord note, delta time is 0 */ - - ++commidi_1.imidi[*icm]; - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0; - } - -/* Note off */ - - ++commidi_1.imidi[*icm]; -/* mmidi(icm,imidi(icm)) = 8*16+icm */ - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) ( - icmm[*icm] + 128); - -/* Pitch */ - - ++commidi_1.imidi[*icm]; - if (ioff == 0) { - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( - shortint) ipsav; - } else { - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( - shortint) commidi_1.mcpitch[ioff - 1]; - } - -/* Vel */ - - ++commidi_1.imidi[*icm]; - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0; - chkimidi_(icm); - if (*endrest) { - return 0; - } - -/* print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time */ - -/* L8: */ - } - comslm_1.naccbl[*icm] = comslm_1.nusebl; - if (comslm_1.nusebl > 0) { - -/* Fix tables of "bar-line" accids that are saved due to consecutive notes. */ - - i__1 = comslm_1.nusebl; - for (kacc = 1; kacc <= i__1; ++kacc) { - comslm_1.laccbl[*icm + kacc * 25 - 25] = comips_1.lusebl[kacc - 1] - ; - comslm_1.jaccbl[*icm + kacc * 25 - 25] = comips_1.jusebl[kacc - 1] - ; -/* L30: */ - } - comslm_1.nusebl = 0; - } - -/* Begin tie checks */ - - if (comslm_1.slmon[*icm]) { - -/* Prior note had a slur start */ - - if (comslm_1.levson[*icm] == comslm_1.levsoff[*icm] && *iacc == 0) { - -/* We have a tie! (Assumed there would be no accidental on tie-ending note) */ -/* Make a list of times of all events back to the one starting at imidso+1, */ -/* which is at or before where the tie started. Ident tie start and stop by */ -/* comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) */ -/* Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial */ -/* time. */ - nsav4tie = 0; - imidt = comslm_1.imidso[*icm]; -L10: - ++nsav4tie; - itiesav[nsav4tie * 5 - 5] = igetvarlen_(commidi_1.mmidi, icm, & - imidt, &nbytes); - imidt += nbytes; - for (j = 1; j <= 3; ++j) { - itiesav[j + 1 + nsav4tie * 5 - 6] = commidi_1.mmidi[*icm + ( - imidt + j) * 25 - 25]; -/* L11: */ - } - imidt += 3; - if (nsav4tie == 1) { - itiesav[4] = itiesav[0]; - } else { - itiesav[nsav4tie * 5 - 1] = itiesav[nsav4tie * 5 - 5] + - itiesav[(nsav4tie - 1) * 5 - 1]; - } - if (imidt != commidi_1.imidi[*icm]) { - goto L10; - } - -/* Find which two pitches agree with saved slur pitch. */ - - it1found = FALSE_; - i__1 = nsav4tie; - for (it2 = 1; it2 <= i__1; ++it2) { - if (itiesav[it2 * 5 - 3] == comips_1.ipslon[*icm]) { - if (it1found) { - goto L13; - } - it1 = it2; - it1found = TRUE_; - } -/* L12: */ - } - printl_("Program error, tied notes, send source to Dr. Don", ( - ftnlen)49); - it1 = nsav4tie + 1; - it2 = nsav4tie + 1; -L13: - -/* List the positions we want to keep */ - - jsav = 0; - i__1 = nsav4tie; - for (isav = 1; isav <= i__1; ++isav) { - if (isav == it1 || isav == it2) { - goto L14; - } - ++jsav; - itk[jsav - 1] = (shortint) isav; -L14: - ; - } - nsav4tie += -2; - -/* Now dump events it1 & it2, recompute times, restack mmidi. */ - - commidi_1.imidi[*icm] = comslm_1.imidso[*icm]; - i__1 = nsav4tie; - for (isav = 1; isav <= i__1; ++isav) { - if (isav == 1) { - idurvar = isetvarlen_(&itiesav[itk[isav - 1] * 5 - 1], & - nbytes); - } else { - i__2 = itiesav[itk[isav - 1] * 5 - 1] - itiesav[itk[isav - - 2] * 5 - 1]; - idurvar = isetvarlen_(&i__2, &nbytes); - } - ++commidi_1.imidi[*icm]; - i__2 = nbytes; - for (i__ = 1; i__ <= i__2; ++i__) { - commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nbytes - - i__) * 25 - 25] = (shortint) (idurvar % 256); - if (nbytes > 1) { - idurvar /= 256; - } -/* L16: */ - } - commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nbytes - 1; - for (i__ = 2; i__ <= 4; ++i__) { - ++commidi_1.imidi[*icm]; - commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = - (shortint) itiesav[i__ + itk[isav - 1] * 5 - 6]; -/* L17: */ - } -/* L15: */ - } - } - comslm_1.slmon[*icm] = FALSE_; - comslm_1.levsoff[*icm] = 0; - if (! comslm_1.dbltie) { - comslm_1.levson[*icm] = 0; - } - } - if (comslm_1.levson[*icm] > 0) { - comslm_1.slmon[*icm] = TRUE_; - } - if (commidi_1.nmidcrd > 0) { - commidi_1.nmidcrd = 0; - } - chkimidi_(icm); - return 0; -} /* addmidi_ */ - -/* Subroutine */ int addstr_(char *notexq, integer *lnote, char *soutq, - integer *lsout, ftnlen notexq_len, ftnlen soutq_len) -{ - /* System generated locals */ - address a__1[2]; - integer i__1[2]; - char ch__1[81]; - - /* Builtin functions */ - integer s_wsfe(cilist *); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer do_fio(integer *, char *, ftnlen), e_wsfe(void); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - - /* Fortran I/O blocks */ - static cilist io___104 = { 0, 11, 0, "(a)", 0 }; - - - if (*lsout + *lnote > 72) { - if (comlast_1.islast) { - s_wsfe(&io___104); -/* Writing concatenation */ - i__1[0] = *lsout, a__1[0] = soutq; - i__1[1] = 1, a__1[1] = "%"; - s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)81); - do_fio(&c__1, ch__1, *lsout + 1); - e_wsfe(); - } - *lsout = 0; - } - if (*lsout > 0) { -/* Writing concatenation */ - i__1[0] = *lsout, a__1[0] = soutq; - i__1[1] = *lnote, a__1[1] = notexq; - s_cat(soutq, a__1, i__1, &c__2, (ftnlen)80); - } else { - s_copy(soutq, notexq, (ftnlen)80, (*lnote)); - } - *lsout += *lnote; - return 0; -} /* addstr_ */ - -/* Subroutine */ int adjusteskz_(integer *ib, real *squez, integer *istart, - integer *istop, real *poenom) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1; - - /* Local variables */ - static integer in, iaskb, inmin; - static real eskadd; - - -/* For block ib, this adds accidental spaces to eskz, for use in getting */ -/* length of xtup bracket and slopes of brackets and beams. */ - - /* Parameter adjustments */ - --istop; - --istart; - --squez; - - /* Function Body */ - inmin = istart[*ib] + 1; - i__1 = comas1_1.naskb; - for (iaskb = 1; iaskb <= i__1; ++iaskb) { - if (comas1_1.task[iaskb - 1] < all_1.to[istart[*ib] - 1] - - comtol_1.tol) { - goto L10; - } - eskadd = comas1_1.wask[iaskb - 1] / *poenom - comas1_1.elask[iaskb - - 1]; - i__2 = comntot_1.ntot; - for (in = inmin; in <= i__2; ++in) { - if (all_1.to[in - 1] > comas1_1.task[iaskb - 1] - comtol_1.tol) { - comeskz2_1.eskz2[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 - - 25] += eskadd; - if ((r__1 = all_1.to[in - 1] - comas1_1.task[iaskb - 1], dabs( - r__1)) < comtol_1.tol) { - --inmin; - } - } else { - ++inmin; - } -/* L11: */ - } -L10: - ; - } - return 0; -} /* adjusteskz_ */ - -/* Subroutine */ int askfig_(char *pathnameq, integer *lpath, char *basenameq, - integer *lbase, logical *figbass, logical *istype0, ftnlen - pathnameq_len, ftnlen basenameq_len) -{ - /* System generated locals */ - address a__1[3], a__2[2]; - integer i__1[3], i__2[2], i__3; - char ch__1[1], ch__2[88], ch__3[15], ch__4[5], ch__5[4]; - olist o__1; - cllist cl__1; - alist al__1; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer f_open(olist *), f_rew(alist *), f_clos(cllist *), s_wsfe(cilist * - ), do_fio(integer *, char *, ftnlen), e_wsfe(void), s_rsfe(cilist - *), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen), s_wsfi( - icilist *), e_wsfi(void), i_indx(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - static integer il; - static char sq[1]; - static integer ihs; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static logical done; - extern integer llen_(char *, integer *, ftnlen); - static char outq[129]; - extern /* Subroutine */ int moveln_(integer *, integer *, logical *); - static integer lenout; - extern /* Subroutine */ int putast_(real *, integer *, char *, ftnlen); - static integer indxask; - - /* Fortran I/O blocks */ - static cilist io___112 = { 0, 12, 0, "(a)", 0 }; - static cilist io___113 = { 0, 12, 0, "(a)", 0 }; - static cilist io___115 = { 0, 11, 1, "(a129)", 0 }; - static icilist io___117 = { 0, outq+11, 0, "(f4.1)", 4, 1 }; - static cilist io___120 = { 0, 12, 0, "(a)", 0 }; - static cilist io___121 = { 0, 16, 1, "(a129)", 0 }; - static cilist io___122 = { 0, 12, 0, "(a)", 0 }; - - - chax_(ch__1, (ftnlen)1, &c__92); - *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; - o__1.oerr = 0; - o__1.ounit = 12; - o__1.ofnmlen = *lpath + *lbase + 4; -/* Writing concatenation */ - i__1[0] = *lpath, a__1[0] = pathnameq; - i__1[1] = *lbase, a__1[1] = basenameq; - i__1[2] = 4, a__1[2] = ".tex"; - s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)88); - o__1.ofnm = ch__2; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); - -/* Transfer first 5 lines of main internal TeX file */ - - for (il = 1; il <= 5; ++il) { - moveln_(&c__11, &c__12, &done); -/* L11: */ - } - if (*istype0) { - -/* Transfer literal TeX stuff from special scratch file */ - - al__1.aerr = 0; - al__1.aunit = 17; - f_rew(&al__1); -L10: - moveln_(&c__17, &c__12, &done); - if (! done) { - goto L10; - } - cl__1.cerr = 0; - cl__1.cunit = 17; - cl__1.csta = 0; - f_clos(&cl__1); - } - -/* Transfer next 2 lines from main scratch file */ - - for (il = 1; il <= 2; ++il) { - moveln_(&c__11, &c__12, &done); -/* L3: */ - } - if (compoi_1.ispoi) { - s_wsfe(&io___112); -/* Writing concatenation */ - i__2[0] = 1, a__2[0] = sq; - i__2[1] = 14, a__2[1] = "input musixpoi"; - s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15); - do_fio(&c__1, ch__3, (ftnlen)15); - e_wsfe(); - } - if (combbm_1.isbbm) { - s_wsfe(&io___113); -/* Writing concatenation */ - i__2[0] = 1, a__2[0] = sq; - i__2[1] = 14, a__2[1] = "input musixbbm"; - s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15); - do_fio(&c__1, ch__3, (ftnlen)15); - e_wsfe(); - } - if (*figbass) { - -/* Transfer .fig data from scratch (unit 14) into external .tex (unit 12) */ - -L4: - moveln_(&c__14, &c__12, &done); - if (! done) { - goto L4; - } - cl__1.cerr = 0; - cl__1.cunit = 14; - cl__1.csta = 0; - f_clos(&cl__1); - } - comas3_1.iask = 0; - ihs = 0; -L1: - i__3 = s_rsfe(&io___115); - if (i__3 != 0) { - goto L999; - } - i__3 = do_fio(&c__1, outq, (ftnlen)129); - if (i__3 != 0) { - goto L999; - } - i__3 = e_rsfe(); - if (i__3 != 0) { - goto L999; - } - -/* Hardspaces. */ - -/* Writing concatenation */ - i__2[0] = 1, a__2[0] = sq; - i__2[1] = 4, a__2[1] = "xard"; - s_cat(ch__4, a__2, i__2, &c__2, (ftnlen)5); - if (s_cmp(outq, ch__4, (ftnlen)5, (ftnlen)5) == 0) { - ++ihs; - *(unsigned char *)&outq[1] = 'h'; - s_wsfi(&io___117); - do_fio(&c__1, (char *)&comhsp_1.hpttot[ihs - 1], (ftnlen)sizeof(real)) - ; - e_wsfi(); - lenout = 19; - goto L9; - } - -/* This part hard-wires ask's into new .tex file as ast's */ - -L2: -/* Writing concatenation */ - i__2[0] = 1, a__2[0] = sq; - i__2[1] = 3, a__2[1] = "ask"; - s_cat(ch__5, a__2, i__2, &c__2, (ftnlen)4); - indxask = i_indx(outq, ch__5, (ftnlen)129, (ftnlen)4); - if (indxask != 0) { - ++comas3_1.iask; - putast_(&comas3_1.ask[comas3_1.iask - 1], &indxask, outq, (ftnlen)129) - ; - goto L2; - } - lenout = llen_(outq, &c__129, (ftnlen)129); -L9: - s_wsfe(&io___120); - do_fio(&c__1, outq, lenout); - e_wsfe(); - -/* If this is the line with "readmod", check for topmods. */ - - if (comas3_1.topmods && s_cmp(outq + 1, "readmod", (ftnlen)7, (ftnlen)7) - == 0) { - comas3_1.topmods = FALSE_; - al__1.aerr = 0; - al__1.aunit = 16; - f_rew(&al__1); - for (il = 1; il <= 1000; ++il) { - i__3 = s_rsfe(&io___121); - if (i__3 != 0) { - goto L8; - } - i__3 = do_fio(&c__1, outq, (ftnlen)129); - if (i__3 != 0) { - goto L8; - } - i__3 = e_rsfe(); - if (i__3 != 0) { - goto L8; - } - lenout = llen_(outq, &c__129, (ftnlen)129); - -/* We inserted the '%' in subroutine littex, to guarantee including blank. */ - - s_wsfe(&io___122); - do_fio(&c__1, outq, lenout); - e_wsfe(); -/* L7: */ - } -L8: - cl__1.cerr = 0; - cl__1.cunit = 16; - cl__1.csta = 0; - f_clos(&cl__1); - } - goto L1; -L999: - cl__1.cerr = 0; - cl__1.cunit = 11; - cl__1.csta = 0; - f_clos(&cl__1); - cl__1.cerr = 0; - cl__1.cunit = 12; - cl__1.csta = 0; - f_clos(&cl__1); - return 0; -} /* askfig_ */ - -/* Subroutine */ int backfill_(integer *iunit, char *oldq, integer *lenold, - char *newq, integer *lennew, ftnlen oldq_len, ftnlen newq_len) -{ - /* System generated locals */ - address a__1[3]; - integer i__1, i__2[3]; - alist al__1; - - /* Builtin functions */ - integer f_back(alist *), s_rsfe(cilist *), do_fio(integer *, char *, - ftnlen), e_rsfe(void), i_indx(char *, char *, ftnlen, ftnlen); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, - char **, integer *, integer *, ftnlen); - integer s_wsfe(cilist *), e_wsfe(void); - - /* Local variables */ - static integer linesback, ndx, line; - static char nowq[128], lineq[128*200]; - - /* Fortran I/O blocks */ - static cilist io___124 = { 0, 0, 0, "(a)", 0 }; - static cilist io___129 = { 0, 0, 0, "(a128)", 0 }; - - - -/* In iunit, looks backward for oldq, overwrites newq */ -/* Safest if both are same length! */ - - linesback = 0; -L1: - al__1.aerr = 0; - al__1.aunit = *iunit; - f_back(&al__1); - io___124.ciunit = *iunit; - s_rsfe(&io___124); - do_fio(&c__1, nowq, (ftnlen)128); - e_rsfe(); - ndx = i_indx(nowq, oldq, (ftnlen)128, (*lenold)); - -/* Save the line just read */ - - ++linesback; - s_copy(lineq + (linesback - 1 << 7), nowq, (ftnlen)128, (ftnlen)128); - if (ndx == 0) { - al__1.aerr = 0; - al__1.aunit = *iunit; - f_back(&al__1); - goto L1; - } - -/* If here, it's replacement time. */ - - i__1 = ndx + *lenold - 1; -/* Writing concatenation */ - i__2[0] = ndx - 1, a__1[0] = nowq; - i__2[1] = *lennew, a__1[1] = newq; - i__2[2] = 128 - i__1, a__1[2] = nowq + i__1; - s_cat(lineq + (linesback - 1 << 7), a__1, i__2, &c__3, (ftnlen)128); - al__1.aerr = 0; - al__1.aunit = *iunit; - f_back(&al__1); - for (line = linesback; line >= 1; --line) { - io___129.ciunit = *iunit; - s_wsfe(&io___129); - do_fio(&c__1, lineq + (line - 1 << 7), (ftnlen)128); - e_wsfe(); -/* L2: */ - } - return 0; -} /* backfill_ */ - -/* Subroutine */ int beamend_(char *notexq, integer *lnote, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[4], a__2[3], a__3[2]; - integer i__1, i__2[4], i__3[3], i__4[2]; - char ch__1[1]; - - /* Builtin functions */ - integer pow_ii(integer *, integer *); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - static integer ip, mp, len, imp; - extern integer log2_(integer *); - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer nole; - static char ulqq[1]; - extern /* Subroutine */ int stop1_(void); - extern integer ncmid_(integer *, integer *); - static integer ndsav; - static char tempq[4], noteq[8]; - extern /* Subroutine */ int notex_(char *, integer *, ftnlen), ntrbbb_( - integer *, char *, char *, integer *, char *, integer *, ftnlen, - ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *, - ftnlen); - static logical isdotm; - static integer lnoten, multip; - extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) - ; - - /* Fortran I/O blocks */ - static cilist io___136 = { 0, 6, 0, 0, 0 }; - static cilist io___137 = { 0, 6, 0, 0, 0 }; - - - ip = all_1.ipo[all_1.jn - 1]; - multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8; - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 4) { - -/* This is the LAST note in the xtup (i.e., all rests before). Make single. */ - - i__1 = 4 - multip; - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); - notex_(notexq, lnote, (ftnlen)79); - strtmid_1.ixrest[commvl_1.ivx - 1] = 0; - return 0; - } - nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; - -/* Check for special situations with 2nds (see precrd) */ - - if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) { - --nole; - } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) { - ++nole; - } - if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { - -/* Xtuplet with no beam, just put in the right kind of note */ - - if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) { - -/* Forced stem direction */ - - ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; - i__1 = 4 - multip; - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); - if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) { - all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2; - } - notex_(notexq, lnote, (ftnlen)79); - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav; - } else { - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - *lnote = lnoten + 3; - if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) - { - -/* Prior note is not regular-dotted */ - - if (multip == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "q"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } else if (multip == -1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "h"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } else if (multip == 1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "c"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } else if (multip == 2) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 2, a__1[1] = "cc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - ++(*lnote); - } else if (multip == 3) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 3, a__1[1] = "ccc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - *lnote += 2; - } else if (multip == -2) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 2, a__2[1] = "wh"; - i__3[2] = 8, a__2[2] = noteq; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - } else if (multip == -3) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 5, a__2[1] = "breve"; - i__3[2] = 8, a__2[2] = noteq; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - *lnote += 3; - } else { - s_wsle(&io___136); - e_wsle(); - s_wsle(&io___137); - do_lio(&c__9, &c__1, "(Error in beamend, send source to " - "Dr. Don)", (ftnlen)42); - e_wsle(); - stop1_(); - } - } else { - -/* Prior note is regular-dotted so this one is halved */ - - if (multip == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "c"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } else if (multip == -1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "q"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } else if (multip == -2) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "h"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - i__2[3] = 8, a__1[3] = noteq; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - } - } - } - return 0; - } - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - *lnote = 0; - -/* New way, with flipend, which was computed in beamstrt. */ - - if (strtmid_1.flipend[commvl_1.ivx - 1] && bit_test(all_1.ipl[ - commvl_1.ivx + ip * 24 - 25],30)) { - i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25]; - chax_(ch__1, (ftnlen)1, &i__1); - *(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - - 1] * 24 - 25] = *(unsigned char *)&ch__1[0]; - } - if (ip > all_1.ibm1[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - - 25]) { - -/* This is not a one-noter from beam-jump. Check if multiplicity has increased */ - - if (bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25],0)) { - -/* Prior note is a rest, check one before that */ - - mp = (all_1.mult[commvl_1.ivx + (ip - 2) * 24 - 25] & 15) - 8; - } else { - mp = (all_1.mult[commvl_1.ivx + (ip - 1) * 24 - 25] & 15) - 8; - } - if (multip > mp) { - -/* Assume 1-3, 2-3, or 1-2 */ - - i__1 = mp + 1; - for (imp = multip; imp >= i__1; --imp) { - ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, - lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); -/* L2: */ - } - } else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) - { - -/* 2nd member of dotted xtup */ - - i__1 = multip + 1; - ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, - lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); - } - } - -/* Beam termination and direction analysis */ - - if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23) && ! - combjmp_1.isbjmp) { - -/* This is the end of the first segment in a jump-beam. ivbj1=ivx will be number */ -/* of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the */ -/* voice of the 2nd part of jumped beam. (May need special treatment for */ -/* multi-segment jump-beams */ - - combjmp_1.isbjmp = TRUE_; - combjmp_1.ivbj1 = commvl_1.ivx; - combjmp_1.ivbj2 = 0; - } - if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) { - -/* This is either a normal beamend or end of a sequence of jump-beam segments, */ -/* so some sort of termination is required */ - - *(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; - if (! combjmp_1.isbjmp || commvl_1.ivx != combjmp_1.ivbj2) { - -/* Normal termination */ - - i__1 = commvl_1.ivx % 24; - ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); - } else { - -/* Terminate a sequence of jump-beam segments. */ - - i__1 = 225 - *(unsigned char *)ulqq; - chax_(ch__1, (ftnlen)1, &i__1); - *(unsigned char *)ulqq = *(unsigned char *)&ch__1[0]; - i__1 = combjmp_1.ivbj1 % 24; - ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); - } - } - -/* And now the note */ - - if (*lnote > 0) { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = all_1.sq; - i__3[2] = 2, a__2[2] = "qb"; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - } else { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = all_1.sq; - i__4[1] = 2, a__3[1] = "qb"; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - } - *lnote += 3; - isdotm = FALSE_; - if (! comxtup_1.vxtup[commvl_1.ivx - 1]) { - i__1 = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 - 25]); - if (pow_ii(&c__2, &i__1) != all_1.nodur[commvl_1.ivx + ip * 24 - 25]) - { - if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) { -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = 1, a__3[1] = "p"; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = 1, a__3[1] = "m"; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - isdotm = TRUE_; - } - ++(*lnote); - } - } - -/* 5/25/08 Allow >12 */ -/* 5/9/10 Up to 24; replace 24 with 0 */ - - if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) { -/* call istring(mod(ivx,12),tempq,len) */ - i__1 = commvl_1.ivx % 24; - istring_(&i__1, tempq, &len, (ftnlen)4); - } else { -/* call istring(mod(ivbj1,12),tempq,len) */ - i__1 = combjmp_1.ivbj1 % 24; - istring_(&i__1, tempq, &len, (ftnlen)4); - } - if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2 && ! bit_test( - all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) { - combjmp_1.isbjmp = FALSE_; - } -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = len, a__3[1] = tempq; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - *lnote += len; -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = lnoten, a__3[1] = noteq; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - *lnote += lnoten; - if (isdotm) { - if (lnoten == 1) { -/* Writing concatenation */ - i__2[0] = *lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "{"; - i__2[2] = 1, a__1[2] = noteq; - i__2[3] = 1, a__1[3] = "}"; - s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); - *lnote += 3; - } else { - i__1 = lnoten - 2; -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = lnoten - 1 - i__1, a__3[1] = noteq + i__1; - s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); - ++(*lnote); - } - } - return 0; -} /* beamend_ */ - -/* Subroutine */ int beamid_(char *notexq, integer *lnote, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[3], a__2[2], a__3[4]; - integer i__1, i__2[3], i__3[2], i__4, i__5, i__6[4]; - real r__1; - char ch__1[1]; - - /* Builtin functions */ - integer pow_ii(integer *, integer *); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - extern integer igetbits_(integer *, integer *, integer *); - extern logical isdotted_(integer *, integer *, integer *); - static integer im, ip, len, ivb, iud, mua, mub, iup; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer nole; - static char ulqq[1]; - extern integer ncmid_(integer *, integer *); - static integer ipmid, iflop, ndsav; - static char noteq[8], tempq[4]; - extern /* Subroutine */ int notex_(char *, integer *, ftnlen); - extern integer levrn_(integer *, integer *, integer *, integer *, integer - *); - static integer nlnum, multl, multr; - extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, - char *, integer *, ftnlen, ftnlen, ftnlen); - static integer ipleft; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static real xnlmid; - static logical isdotm; - static integer lnoten, mprint, multip; - extern /* Subroutine */ int putxtn_(integer *, integer *, integer *, - integer *, real *, real *, integer *, integer *, real *, real *, - integer *, integer *, char *, integer *, integer *, real *, - integer *, integer *, logical *, ftnlen); - static integer ipright; - extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) - ; - - *lnote = 0; - ip = all_1.ipo[all_1.jn - 1]; - nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; - -/* Check for special situations with 2nds (see precrd) */ - - if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) { - --nole; - } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) { - ++nole; - } - if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { - multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8; -/* if (btest(islur(ivx,ip-1),3)) multip = multip+1 */ - -/* (Above test OK since must have ip>1). Double dotted note preceding */ - -/* Move the following, because can't ask for note until after checking for */ -/* embedded xtup with number, due to ordering/octave feature. */ - -/* call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) */ - } - if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],28)) { - comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_; - } - if (comxtup_1.vxtup[commvl_1.ivx - 1]) { - -/* In an xtup */ - - if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { - -/* Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK */ - - i__1 = 4 - ((all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8); - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); - notex_(notexq, lnote, (ftnlen)79); - -/* Re-zero so next note does not get confused */ - - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = 0; - return 0; - } -/* if (multip.le.0) then */ -/* if (multip.le.0 .or. */ -/* * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then */ - if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { - -/* Xtuplet with no beam, just put in the right kind of note */ - - if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) { - -/* Forced stem direction */ - - ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; - i__1 = 4 - multip; - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, & - i__1); - if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) || - bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) - { - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = all_1.nodur[ - commvl_1.ivx + ip * 24 - 25] * 3 / 2; - } else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - - 25],27)) { - all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2; - } - notex_(notexq, lnote, (ftnlen)79); - all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav; - } else { - -/* Use ulq for stem direction */ - - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - *lnote = 3; - if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25], - 27)) { - -/* Prior note is not regular-dotted */ - - if (multip == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "q"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == -1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "h"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == 1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "c"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == 2) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 2, a__1[1] = "cc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - *lnote = 4; - } else if (multip == 3) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 3, a__1[1] = "ccc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - *lnote = 5; - } else if (multip == -2) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 2, a__2[1] = "wh"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } - if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) - { - -/* This note is regular dotted non-beamed xtup */ - -/* Writing concatenation */ - i__3[0] = 3, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote = 4; - } - } else { - -/* Prior note is regular-dotted so this one is halved */ - - if (multip == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "c"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == -1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "q"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == -2) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "h"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } - } -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 8, a__2[1] = noteq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += lnoten; - } - return 0; - } else if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) { - -/* In the beamed xtup but not the last note */ - - if (all_1.nodur[commvl_1.ivx + (ip - 1) * 24 - 25] > 0) { - -/* Embedded Xtup, mult>0, starts here. Put in number if needed */ - - ++comxtup_1.nxtinbm[commvl_1.ivx - 1]; - iud = 1; - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25] == 'u') { - iud = -1; - } - -/* Get ip#, notelevel of middle note (or gap) in xtup */ - - ipmid = ip + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25] / 2; - i__1 = ncmid_(&all_1.iv, &ipmid); - i__4 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8; - xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24 - - 25], &all_1.irest[commvl_1.ivx + ipmid * 24 - 25], & - iud, &i__1, &i__4); - if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25] % 2 == 0) { - i__4 = ipmid - 1; - i__1 = ncmid_(&all_1.iv, &i__4); - i__5 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 - - 25]) - 8; - xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + ( - ipmid - 1) * 24 - 25], &all_1.irest[commvl_1.ivx - + (ipmid - 1) * 24 - 25], &iud, &i__1, &i__5)) / - 2; - } - iflop = 0; - if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ip), dabs(r__1)) < - 3.f) { - iflop = -iud; - } - iup = iud + (iflop << 1); - if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],14)) { - iup = -iup; - iflop = 0; - if (iud * iup < 0) { - iflop = iup; - } - } - -/* Place number if needed */ - - if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],31)) { - mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - - 25], &c__5, &c__22); - if (mprint == 0) { - mprint = comxtup_1.mtupv[commvl_1.ivx + - comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25] - ; - } - i__1 = ncmid_(&all_1.iv, &ip); - putxtn_(&mprint, &iflop, &multip, &iud, &comask_1.wheadpt, - &comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx - - 1], &comxtup_1.islope[commvl_1.ivx - 1], & - all_1.slfac, &xnlmid, &all_1.islur[commvl_1.ivx + - ip * 24 - 25], lnote, notexq, &i__1, &nlnum, & - comxtup_1.eloff[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25], &iup, &all_1.irest[ - commvl_1.ivx + ip * 24 - 25], &c_false, (ftnlen) - 79); - } - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - } else { - -/* Intermediate note of xtup */ - - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - } - } else { - -/* Last note of xtup (but not last note of beam!) */ - - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - } - } else if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { - notex_(notexq, lnote, (ftnlen)79); - return 0; - } else { - i__1 = ncmid_(&all_1.iv, &ip); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - } - -/* Check if multiplicity changes in a way requiring action */ - - ipleft = ip - 1; - if (bit_test(all_1.irest[commvl_1.ivx + ipleft * 24 - 25],0)) { - --ipleft; - } - if (! bit_test(all_1.islur[commvl_1.ivx + ipleft * 24 - 25],20)) { - multl = (15 & all_1.mult[commvl_1.ivx + ipleft * 24 - 25]) - 8; - } else { - multl = 1; - } - mub = multip - multl; - ipright = ip + 1; - if (bit_test(all_1.irest[commvl_1.ivx + ipright * 24 - 25],0)) { - ++ipright; - } - if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],20)) { - multr = (15 & all_1.mult[commvl_1.ivx + ipright * 24 - 25]) - 8; - } else { - multr = 1; - } - mua = multr - multip; - if (mub > 0 || mua < 0) { - -/* Multiplicity has increased from left or will decrease to right. Need action. */ - - if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2) { - ivb = combjmp_1.ivbj1; - i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; - chax_(ch__1, (ftnlen)1, &i__1); - *(unsigned char *)ulqq = *(unsigned char *)&ch__1[0]; - } else { - ivb = commvl_1.ivx; - *(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[ - commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; - } - if (mua >= 0) { - ntrbbb_(&multip, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); - } else if (multl >= multr) { - i__1 = multr + 1; - for (im = multip; im >= i__1; --im) { - ntrbbb_(&im, "t", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); -/* L1: */ - } - } else { - i__1 = multip; - for (im = multr + 1; im <= i__1; ++im) { - ntrbbb_(&im, "r", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); -/* L2: */ - } - ntrbbb_(&multr, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( - ftnlen)1, (ftnlen)79); - } - } else if (ip > 1) { - -/* Check for 2nd member of dotted xtup */ - - if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) { - i__1 = multip + 1; - ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, - lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); - } - } - -/* Now put in the note */ - - if (*lnote > 0) { -/* Writing concatenation */ - i__2[0] = *lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = all_1.sq; - i__2[2] = 2, a__1[2] = "qb"; - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 2, a__2[1] = "qb"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } - *lnote += 3; - isdotm = FALSE_; - if (isdotted_(all_1.nodur, &commvl_1.ivx, &ip)) { - -/* rule out ')' */ - - if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) { - if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],3)) { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } else { - -/* Double dot */ - -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 2, a__2[1] = "pp"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - } else { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "m"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - isdotm = TRUE_; - } - ++(*lnote); - } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) || - bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) { - -/* Special dotted notation for 2:1 xtup, or normal dot in xtup */ - -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - -/* 5/25/08 Allow >12 */ - - if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) { -/* call istring(mod(ivx,12),tempq,len) */ - i__1 = commvl_1.ivx % 24; - istring_(&i__1, tempq, &len, (ftnlen)4); - } else { -/* call istring(mod(ivbj1,12),tempq,len) */ - i__1 = combjmp_1.ivbj1 % 24; - istring_(&i__1, tempq, &len, (ftnlen)4); - } -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = len, a__2[1] = tempq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += len; -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = lnoten, a__2[1] = noteq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += lnoten; - if (isdotm) { - if (lnoten == 2) { -/* Writing concatenation */ - i__6[0] = *lnote, a__3[0] = notexq; - i__6[1] = 1, a__3[1] = "{"; - i__6[2] = 1, a__3[2] = noteq + 1; - i__6[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__6, &c__4, (ftnlen)79); - *lnote += 3; - } else { - i__1 = lnoten - 2; -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - } - return 0; -} /* beamid_ */ - -/* Subroutine */ int beamn1_(char *notexq, integer *lnote, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[3], a__2[2], a__3[4]; - integer i__1, i__2[3], i__3[2], i__4[4]; - - /* Builtin functions */ - integer pow_ii(integer *, integer *); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - static integer nd, im, ip1, len; - extern integer log2_(integer *); - static integer nole; - extern /* Subroutine */ int stop1_(void); - extern integer ncmid_(integer *, integer *); - static integer ndsav; - static char noteq[8]; - extern /* Subroutine */ int notex_(char *, integer *, ftnlen); - static integer multr; - extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, - char *, integer *, ftnlen, ftnlen, ftnlen), notefq_(char *, - integer *, integer *, integer *, ftnlen); - static logical isdotm; - static integer lnoten, multip; - extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) - ; - - /* Fortran I/O blocks */ - static cilist io___175 = { 0, 6, 0, 0, 0 }; - static cilist io___176 = { 0, 6, 0, 0, 0 }; - - - ip1 = all_1.ipo[all_1.jn - 1]; - multip = (15 & all_1.mult[commvl_1.ivx + ip1 * 24 - 25]) - 8; -/* if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then */ - if (! comdraw_1.drawbm[commvl_1.ivx - 1] && bit_test(all_1.irest[ - commvl_1.ivx + ip1 * 24 - 25],0)) { - *lnote = 0; - -/* The rest was already written in beamstrt, so just get out of here */ - - return 0; - } - nole = all_1.nolev[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25]; - -/* Check for special situations with 2nds (see precrd) */ - - if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25], - 30)) { - --nole; - } else if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * - 24 - 25],31)) { - ++nole; - } - if (comxtup_1.vxtup[commvl_1.ivx - 1] && ! comdraw_1.drawbm[commvl_1.ivx - - 1]) { - -/* Xtuplet with no beam, just put in the right kind of note */ - - if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],30)) { - -/* Forced stem direction */ - - ndsav = all_1.nodur[commvl_1.ivx + ip1 * 24 - 25]; - i__1 = 4 - multip; - all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = pow_ii(&c__2, &i__1); - if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || - bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { - all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = all_1.nodur[ - commvl_1.ivx + ip1 * 24 - 25] * 3 / 2; - } - notex_(notexq, lnote, (ftnlen)79); - all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = ndsav; - } else { - i__1 = ncmid_(&all_1.iv, &ip1); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - *lnote = 3; - if (multip == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "q"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == -1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "h"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == 1) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 1, a__1[1] = "c"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else if (multip == 2) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 2, a__1[1] = "cc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - *lnote = 4; - } else if (multip == 3) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = all_1.sq; - i__2[1] = 3, a__1[1] = "ccc"; - i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + - all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - *lnote = 5; - } else if (multip == -2) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 2, a__2[1] = "wh"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } else if (multip == -3) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 5, a__2[1] = "breve"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote = 6; - } else { - s_wsle(&io___175); - e_wsle(); - s_wsle(&io___176); - do_lio(&c__9, &c__1, "(Error in beamn1, send source to Dr. D" - "on)", (ftnlen)41); - e_wsle(); - stop1_(); - } - if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || - bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { -/* Writing concatenation */ - i__3[0] = 3, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote = 4; - } -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 8, a__2[1] = noteq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += lnoten; - } - return 0; - } - -/* Check if mult. decreases from 1st note to 2nd */ - - if (all_1.ibm2[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25] > - ip1 || bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) { - -/* More than one note or single-note before a multiplicity-down-up "][" */ - - if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) { - multr = 1; - } else if (! bit_test(all_1.irest[commvl_1.ivx + (ip1 + 1) * 24 - 25], - 0)) { - multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 1) * 24 - 25]) - 8; - } else { - multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 2) * 24 - 25]) - 8; - } - *lnote = 0; - if (multr < multip) { - i__1 = multr + 1; - for (im = multip; im >= i__1; --im) { - ntrbbb_(&im, "r", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, - lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); -/* L1: */ - } - } - } - -/* Put in the note */ - - if (*lnote > 0) { -/* Writing concatenation */ - i__2[0] = *lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = all_1.sq; - i__2[2] = 2, a__1[2] = "qb"; - s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = all_1.sq; - i__3[1] = 2, a__2[1] = "qb"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } - *lnote += 3; - -/* Check for dot */ - - isdotm = FALSE_; - if (! comxtup_1.vxtup[commvl_1.ivx - 1]) { - nd = all_1.nodur[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25]; - if (nd != 0) { - i__1 = log2_(&nd); - if (pow_ii(&c__2, &i__1) != nd) { - if (! bit_test(all_1.iornq[commvl_1.ivx + ip1 * 24 - 1],13)) { - if (! bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25], - 3)) { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - } else { - -/* Double dot */ - -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 2, a__2[1] = "pp"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - } else { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "m"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - isdotm = TRUE_; - } - ++(*lnote); - } - } - } else if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || - bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { - -/* In an xtup with special 2:1 notation with a dot on 1st note, or normal dot */ - -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = 1, a__2[1] = "p"; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - -/* Do the number; 0 if 12 */ - -/* 5/25/08 allow >12 */ - - if (! bit_test(all_1.irest[commvl_1.ivx + ip1 * 24 - 25],24)) { -/* call istring(mod(ivx,12),noteq,len) */ - i__1 = commvl_1.ivx % 24; - istring_(&i__1, noteq, &len, (ftnlen)8); - } else { -/* call istring(mod(ivbj1,12),noteq,len) */ - i__1 = combjmp_1.ivbj1 % 24; - istring_(&i__1, noteq, &len, (ftnlen)8); - } -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = len, a__2[1] = noteq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += len; - i__1 = ncmid_(&all_1.iv, &ip1); - notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = lnoten, a__2[1] = noteq; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - *lnote += lnoten; - if (isdotm) { - if (lnoten == 1) { -/* Writing concatenation */ - i__4[0] = *lnote, a__3[0] = notexq; - i__4[1] = 1, a__3[1] = "{"; - i__4[2] = 1, a__3[2] = noteq; - i__4[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); - *lnote += 3; - } else { - i__1 = lnoten - 2; -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1; - s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); - ++(*lnote); - } - } - return 0; -} /* beamn1_ */ - -/* Subroutine */ int beamstrt_(char *notexq, integer *lnote, integer *nornb, - integer *ihornb, real *space, real *squez, integer *ib, ftnlen - notexq_len) -{ - /* System generated locals */ - address a__1[3], a__2[2]; - integer i__1, i__2, i__3, i__4[3], i__5[2]; - real r__1; - icilist ici__1; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer i_nint(real *), s_wsfi(icilist *), do_fio(integer *, char *, - ftnlen), e_wsfi(void), pow_ii(integer *, integer *); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer i_sign(integer *, integer *), lbit_shift(integer, integer); - - /* Local variables */ - static logical addbrack; - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - extern integer igetbits_(integer *, integer *, integer *); - static logical usexnumt; - static integer nomornlev, ip, levbracket, ibc, inb, iud, imp, ivf, ipp, - iup; - static logical xto; - static integer ipb1, iadj, icrd; - extern doublereal feon_(real *); - static integer levc, iorn; - static real ymin, ybot; - static integer levx; - static real xnsk; - extern integer ncmid_(integer *, integer *); - static real ybeam; - static integer ipmid, iflop; - static real bmlev; - static integer icrdx, multb, ltemp; - static char noteq[8], tempq[79]; - extern integer levrn_(integer *, integer *, integer *, integer *, integer - *); - static integer nlnum; - extern /* Subroutine */ int notex_(char *, integer *, ftnlen); - static integer isssb; - static real zmult; - extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, - char *, integer *, ftnlen, ftnlen, ftnlen); - static real xnlmid; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static integer lnoten; - extern /* Subroutine */ int setupb_(real *, integer *, real *, real *, - integer *, real *, integer *); - static integer mprint; - static real xslope; - extern /* Subroutine */ int putxtn_(integer *, integer *, integer *, - integer *, real *, real *, integer *, integer *, real *, real *, - integer *, integer *, char *, integer *, integer *, real *, - integer *, integer *, logical *, ftnlen); - static integer maxdrop; - - -/* The following is just to save the outputs from SetupB for the case of */ -/* xtups starting with a rest, where beamstrt is called twice. */ - - /* Parameter adjustments */ - --squez; - --space; - ihornb -= 25; - --nornb; - - /* Function Body */ - ibc = all_1.ibmcnt[commvl_1.ivx - 1]; - ipb1 = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; - multb = (15 & all_1.mult[commvl_1.ivx + ipb1 * 24 - 25]) - 8; - ip = all_1.ipo[all_1.jn - 1]; - -/* Compute slopes and note offsets from start of beam. Inside SetupB, for each */ -/* xtup in the beam, set eloff,mtupv (in comxtup) for printed number. */ - - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0 && ! bit_test(all_1.nacc[ - commvl_1.ivx + ip * 24 - 25],21)) { - setupb_(comxtup_1.xelsk, &comipb_1.nnb, &comipb_1.sumx, & - comipb_1.sumy, comipb_1.ipb, &comipb_1.smed, & - strtmid_1.ixrest[commvl_1.ivx - 1]); - } - if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],21)) { - -/* This is start of later segment of single-slope beam group so use slope and */ -/* height from prior beam. Slope is already OK. */ - - ++comxtup_1.issb[commvl_1.ivx - 1]; - comxtup_1.nolev1[commvl_1.ivx - 1] = comxtup_1.lev1ssb[commvl_1.ivx + - comxtup_1.issb[commvl_1.ivx - 1] * 24 - 25]; - } - *lnote = 0; - comdraw_1.drawbm[commvl_1.ivx - 1] = TRUE_; - if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],28) && - strtmid_1.ixrest[commvl_1.ivx - 1] != 2) { - comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_; - ++comxtup_1.nxtinbm[commvl_1.ivx - 1]; - -/* irest(28)=>Xtup starts on this note. Set up for xtuplet. */ -/* Number goes on notehead side at middle note (or gap) of xtup, unless that */ -/* puts it in staff, then it flops to stem (or beam) side. */ -/* __ __ */ -/* | | | O | | */ -/* O | | O */ -/* |___| O |__| | */ - -/* iud -1 -1 1 1 ...stem direction */ -/* iflop 0 1 -1 0 ...direction of flop */ -/* iup -1 1 -1 1 ...direction of number and bracket */ - - iud = 1; - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u') - { - iud = -1; - } - -/* Get ip#, note level of middle note (or gap) in xtup */ - - ipmid = ipb1 + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25] / 2; - i__1 = ncmid_(&all_1.iv, &ipmid); - i__2 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8; - xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24 - 25], & - all_1.irest[commvl_1.ivx + ipmid * 24 - 25], &iud, &i__1, & - i__2); - if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[commvl_1.ivx - 1] - * 24 - 25] % 2 == 0) { - i__2 = ipmid - 1; - i__1 = ncmid_(&all_1.iv, &i__2); - i__3 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 - 25]) - - 8; - xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + (ipmid - 1) - * 24 - 25], &all_1.irest[commvl_1.ivx + (ipmid - 1) * 24 - - 25], &iud, &i__1, &i__3)) / 2; - } - iflop = 0; - if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ipb1), dabs(r__1)) < 3.f) { - iflop = -iud; - } - iup = iud + (iflop << 1); - if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],14)) { - -/* Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) */ - - iup = -iup; - iflop = 0; - if (iud * iup < 0) { - iflop = iup; - } - } - -/* Determine if a beam is to be drawn */ - - i__1 = all_1.ibm2[commvl_1.ivx + ibc * 24 - 25]; - for (ipp = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; ipp <= i__1; - ++ipp) { - if ((15 & all_1.mult[commvl_1.ivx + ipp * 24 - 25]) - 8 <= 0) { - comdraw_1.drawbm[commvl_1.ivx - 1] = FALSE_; - goto L6; - } -/* L5: */ - } - comdraw_1.drawbm[commvl_1.ivx - 1] = ! bit_test(all_1.islur[ - commvl_1.ivx + all_1.ibm1[commvl_1.ivx + ibc * 24 - 25] * 24 - - 25],18); -L6: - -/* Are we using tuplet.tex? */ - - usexnumt = comnvst_1.cstuplet && ! comdraw_1.drawbm[commvl_1.ivx - 1]; - -/* Place xtup number if needed */ - - if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31) || - multb <= 0) { - mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - 25], & - c__5, &c__22); - if (mprint == 0) { - mprint = comxtup_1.mtupv[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25]; - } - i__1 = ncmid_(&all_1.iv, &ipb1); - putxtn_(&mprint, &iflop, &multb, &iud, &comask_1.wheadpt, & - comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx - 1], & - comxtup_1.islope[commvl_1.ivx - 1], &all_1.slfac, &xnlmid, - &all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], lnote, - notexq, &i__1, &nlnum, &comxtup_1.eloff[commvl_1.ivx + - comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25], &iup, & - all_1.irest[commvl_1.ivx + ipb1 * 24 - 25], &usexnumt, ( - ftnlen)79); - } - if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { - -/* Xtuplet with no beam */ - - if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31)) { - -/* Number printing has not been suppressed, so put in the bracket. */ -/* scale = stretch factor for bracket if there are asx's */ -/* xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) */ - - r__1 = space[*ib] / squez[*ib]; - xnsk = (comeskz2_1.eskz2[commvl_1.ivx + (ipb1 + - comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ - commvl_1.ivx - 1] * 24 - 25] - 1) * 24 - 25] - - comeskz2_1.eskz2[commvl_1.ivx + ipb1 * 24 - 25]) / - squez[*ib] / feon_(&r__1); - if (iup == 1) { - if (*lnote > 0) { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 5, a__1[2] = "ovbkt"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - } else { -/* Writing concatenation */ - i__5[0] = 1, a__2[0] = all_1.sq; - i__5[1] = 5, a__2[1] = "ovbkt"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - } - } else { - if (*lnote > 0) { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 5, a__1[2] = "unbkt"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - } else { - -/* Introduced 12/5/98, req'd due to possible presence of in-line TeX */ - -/* Writing concatenation */ - i__5[0] = 1, a__2[0] = all_1.sq; - i__5[1] = 5, a__2[1] = "unbkt"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - } - } - *lnote += 6; - if (all_1.iline == 1) { - comipb_1.smed /= 1.f - comtop_1.fracindent; - } - xslope = comipb_1.smed * 1.8f * all_1.slfac; - comxtup_1.islope[commvl_1.ivx - 1] = i_nint(&xslope); - r__1 = comipb_1.smed * comxtup_1.eloff[commvl_1.ivx - 1]; - comxtup_1.nolev1[commvl_1.ivx - 1] = nlnum - i_nint(&r__1); - if (comxtup_1.islope[commvl_1.ivx - 1] == 0) { - --comxtup_1.nolev1[commvl_1.ivx - 1]; - } - if (iup == 1) { - comxtup_1.nolev1[commvl_1.ivx - 1] += 4; - } - levbracket = comxtup_1.nolev1[commvl_1.ivx - 1]; - if (iup == 1 && comnvst_1.cstuplet) { - --levbracket; - } - i__1 = ncmid_(&all_1.iv, &ipb1); - notefq_(noteq, &lnoten, &levbracket, &i__1, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = lnoten, a__1[1] = noteq; - i__4[2] = 1, a__1[2] = "{"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote = *lnote + lnoten + 1; - if (xnsk < .995f) { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 4 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(i1,f3.2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer)); - do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); - e_wsfi(); - *lnote += 4; - } else if (xnsk < 9.995f) { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 4 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(f4.2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); - e_wsfi(); - *lnote += 4; - } else { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 5 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(f5.2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); - e_wsfi(); - *lnote += 5; - } -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - ++(*lnote); - if (bit_test(all_1.mult[commvl_1.ivx + ipb1 * 24 - 25],4)) { - -/* Tweak slope of bracket */ - - comxtup_1.islope[commvl_1.ivx - 1] = comxtup_1.islope[ - commvl_1.ivx - 1] + igetbits_(&all_1.mult[ - commvl_1.ivx + ipb1 * 24 - 25], &c__5, &c__5) - - 16; - } - if (comxtup_1.islope[commvl_1.ivx - 1] < 0 || - comxtup_1.islope[commvl_1.ivx - 1] >= 10) { -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = 1, a__2[1] = "{"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - ++(*lnote); - if (comxtup_1.islope[commvl_1.ivx - 1] < -9) { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 3 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(i3)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - - 1], (ftnlen)sizeof(integer)); - e_wsfi(); - *lnote += 3; - } else { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 2 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(i2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - - 1], (ftnlen)sizeof(integer)); - e_wsfi(); - *lnote += 2; - } -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - ++(*lnote); - } else { - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + 1 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(i1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], - (ftnlen)sizeof(integer)); - e_wsfi(); - ++(*lnote); - } - -/* Done with bracket */ - - } - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) { - -/* Put in the rest. Possible problem: Rest is a spacing char, but between */ -/* beamstrt and beamn1 some non-spacing chars. are inserted. */ - - if (multb == 0) { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 2, a__1[2] = "qp"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote += 3; - } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 1) - { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 2, a__1[2] = "ds"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote += 3; - } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 2) - { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 2, a__1[2] = "qs"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote += 3; - } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 3) - { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 2, a__1[2] = "hs"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote += 3; - } else { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 6, a__1[2] = "hpause"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote += 7; - } - -/* No need to come back through this subroutine (as would if rest starts bar */ -/* & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. */ - - strtmid_1.ixrest[commvl_1.ivx - 1] = 0; - } - return 0; - } - -/* End if block for non-beamed xtup start...note we returned */ - - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) { - -/* Insert rest at start of beamed xtup. See above note for possible problem. */ - - i__1 = 4 - multb; - all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = pow_ii(&c__2, &i__1); - notex_(tempq, <emp, (ftnlen)79); - if (*lnote > 0) { -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = ltemp, a__2[1] = tempq; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - } else { - s_copy(notexq, tempq, (ftnlen)79, ltemp); - } - *lnote += ltemp; - -/* Re-zero just in case! */ - - all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = 0; - ++all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; - -/* See if next note is a non-rest */ - - if (! bit_test(all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],0) - ) { - strtmid_1.ixrest[commvl_1.ivx - 1] = 2; - } else { - -/* Suppress reprinting xtup number next time through beamstrt */ - - all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set( - all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25],31); - -/* Set new xtup start flag */ - - all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set( - all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],28); - } - return 0; - } - } - -/* Just ended if block for xtups */ - - if (comxtup_1.vxtup[commvl_1.ivx - 1] && ipb1 == all_1.ibm2[commvl_1.ivx - + ibc * 24 - 25]) { - -/* Move actual note writing to beamend */ - - strtmid_1.ixrest[commvl_1.ivx - 1] = 4; - return 0; - } - if (comxtup_1.issb[commvl_1.ivx - 1] == 0) { - -/* 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed */ - - iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, & - c__11) - 30; - if (iadj != -30) { - comxtup_1.nolev1[commvl_1.ivx - 1] += iadj; - i__1 = comxtup_1.nssb[commvl_1.ivx - 1]; - for (isssb = 1; isssb <= i__1; ++isssb) { - comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] += iadj; -/* L2: */ - } - } - iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, & - c__17) - 30; - if (iadj != -30) { - comxtup_1.islope[commvl_1.ivx - 1] += iadj; - if ((i__1 = comxtup_1.islope[commvl_1.ivx - 1], abs(i__1)) > 9) { - comxtup_1.islope[commvl_1.ivx - 1] = i_sign(&c__9, & - comxtup_1.islope[commvl_1.ivx - 1]); - } - if (comxtup_1.nssb[commvl_1.ivx - 1] > 0) { - -/* Cycle thru non-rest notes in SSBG, looking for bmstrts. */ - - isssb = 0; - i__1 = comipb_1.nnb; - for (inb = 2; inb <= i__1; ++inb) { - if (bit_test(all_1.nacc[commvl_1.ivx + comipb_1.ipb[inb - - 1] * 24 - 25],21)) { - -/* Beam segment start. New start level */ - ++isssb; - comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] += - comxtup_1.islope[commvl_1.ivx - 1] * - comxtup_1.xelsk[inb - 1] / all_1.slfac; - } -/* L4: */ - } - } - } - } - iadj = igetbits_(&all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], &c__2, & - c__27); - addbrack = FALSE_; - if (bit_test(all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25],30)) { - -/* Check for altered starting polarity. Only in forced beams. Nominal start */ -/* level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). */ - - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u' - && comxtup_1.nolev1[commvl_1.ivx - 1] + 6 < all_1.nolev[ - commvl_1.ivx + ipb1 * 24 - 25]) { - if (*lnote == 0) { -/* Writing concatenation */ - i__5[0] = 1, a__2[0] = all_1.sq; - i__5[1] = 5, a__2[1] = "loff{"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 5, a__1[2] = "loff{"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - } - *lnote += 6; - addbrack = TRUE_; - } else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] - == 'l' && comxtup_1.nolev1[commvl_1.ivx - 1] - 6 > - all_1.nolev[commvl_1.ivx + ipb1 * 24 - 25]) { - if (*lnote == 0) { -/* Writing concatenation */ - i__5[0] = 1, a__2[0] = all_1.sq; - i__5[1] = 5, a__2[1] = "roff{"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = 1, a__1[1] = all_1.sq; - i__4[2] = 5, a__1[2] = "roff{"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - } - *lnote += 6; - addbrack = TRUE_; - } - -/* Check end level for possible flipping in forced beam. Have to do it */ -/* here since with multiple voices, xelsk will not be preserved. */ - - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25] == 'u') { - bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] + 6 + comxtup_1.islope[ - commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] / - all_1.slfac; - strtmid_1.flipend[commvl_1.ivx - 1] = bmlev < (real) all_1.nolev[ - commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] * - 24 - 25]; - } else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ - commvl_1.ivx - 1] * 24 - 25] == 'l') { - bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] - 6 + comxtup_1.islope[ - commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] / - all_1.slfac; - strtmid_1.flipend[commvl_1.ivx - 1] = bmlev > (real) all_1.nolev[ - commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] * - 24 - 25]; - } - } - i__1 = multb + iadj; - ntrbbb_(&i__1, "i", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), & - commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); - -/* Put in name of start level and slope, after correcting nolev1 if xtup */ -/* started with a rest. */ - - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) { - r__1 = comxtup_1.nolev1[commvl_1.ivx - 1] + comxtup_1.xelsk[0] * - comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac; - comxtup_1.nolev1[commvl_1.ivx - 1] = i_nint(&r__1); - } - i__1 = ncmid_(&all_1.iv, &ipb1); - notefq_(noteq, &lnoten, &comxtup_1.nolev1[commvl_1.ivx - 1], &i__1, ( - ftnlen)8); - if (comxtup_1.islope[commvl_1.ivx - 1] < 0) { -/* Writing concatenation */ - i__4[0] = *lnote, a__1[0] = notexq; - i__4[1] = lnoten, a__1[1] = noteq; - i__4[2] = 1, a__1[2] = "{"; - s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); - *lnote = *lnote + 4 + lnoten; - i__1 = *lnote - 3; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(i2,a1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen) - sizeof(integer)); - do_fio(&c__1, "}", (ftnlen)1); - e_wsfi(); - } else { -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = lnoten, a__2[1] = noteq; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - *lnote = *lnote + 1 + lnoten; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 1; - ici__1.iciunit = notexq + (*lnote - 1); - ici__1.icifmt = "(i1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen) - sizeof(integer)); - e_wsfi(); - } - -/* Check for beam-thk fine-tuning */ - - if (iadj > 0) { - i__1 = multb + 1; - for (imp = multb + iadj; imp >= i__1; --imp) { - ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), & - commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, ( - ftnlen)79); -/* L1: */ - } - } - -/* If we shifted, must close with right bracket */ - - if (addbrack) { -/* Writing concatenation */ - i__5[0] = *lnote, a__2[0] = notexq; - i__5[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); - ++(*lnote); - } - -/* Get 'floor' zmin for figures */ -/* Note: Will not come thru here on 1st note of unbeamed xtup, so figure height */ -/* won't be adjusted. If anyone ever needs that, need to duplicate this */ -/* functionality up above, before exiting. */ - - if (all_1.figbass && (commvl_1.ivx == 1 || commvl_1.ivx == - comfig_1.ivxfig2)) { - if (commvl_1.ivx == 1) { - ivf = 1; - } else { - ivf = comfig_1.ivxfig2; - } - zmult = (multb - 1) * 1.2f; - ymin = 100.f; - i__1 = comipb_1.nnb; - for (inb = 1; inb <= i__1; ++inb) { - if (all_1.isfig[ivf + (comipb_1.ipb[inb - 1] << 1) - 3]) { - if (*(unsigned char *)&all_1.ulq[all_1.iv + ibc * 24 - 25] == - 'u') { - ybot = (real) all_1.nolev[all_1.iv + comipb_1.ipb[inb - 1] - * 24 - 25]; - } else { - ybot = comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac * - comxtup_1.xelsk[inb - 1] + comxtup_1.nolev1[ - commvl_1.ivx - 1] - all_1.stemlen - zmult; - } - ymin = dmin(ymin,ybot); - } -/* L3: */ - } - maxdrop = ncmid_(&all_1.iv, &ipb1) - 4 - ymin + 5.01f; -/* Computing MAX */ - i__1 = all_1.ifigdr[ivf + (all_1.iline << 1) - 3]; - all_1.ifigdr[ivf + (all_1.iline << 1) - 3] = max(i__1,maxdrop); - } - -/* Compute ornament levels if needed */ - - nomornlev = ncmid_(&all_1.iv, &ipb1) + 5; - iorn = 0; - i__1 = comipb_1.nnb; - for (inb = 1; inb <= i__1; ++inb) { - ip = comipb_1.ipb[inb - 1]; - if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],23)) { - goto L8; - } - if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],26) && *( - unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == - 'l') { - -/* letter-dynamic or hairpin ending under down-beamed */ - - ++iorn; - ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] - all_1.stemlen + - comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[inb - - 1] / all_1.slfac + 1 - (multb - 1) * 1.2f; -/* Computing MIN */ - r__1 = ybeam - 3.f; - i__2 = i_nint(&r__1), i__3 = nomornlev - 10; - ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3); - } else if (! bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) { - -/* Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F */ -/* 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD */ - -/* Non-chord. There IS an ornament. Need ihornb only if upbeam, and if */ -/* ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) */ - - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == - 'u' && (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] * - 24 - 1] & 4163566) > 0) { - ++iorn; - all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set(all_1.iornq[ - commvl_1.ivx + ip * 24 - 1],22); - ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] + all_1.stemlen + - comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[ - inb - 1] / all_1.slfac - 1 + (multb - 1) * 1.2f; -/* Computing MAX */ - r__1 = ybeam + 3.f; - i__2 = i_nint(&r__1); - ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev); - } - } else { - -/* In a chord. Orn may be on main note or non-main or both. Set ihornb if */ -/* upbeam and highest note has orn, or down beam and lowest. Find 1st chord note */ - - i__2 = comtrill_1.ncrd; - for (comtrill_1.icrd1 = 1; comtrill_1.icrd1 <= i__2; - ++comtrill_1.icrd1) { - if ((255 & comtrill_1.icrdat[comtrill_1.icrd1 - 1]) == ip && ( - 15 & lbit_shift(comtrill_1.icrdat[comtrill_1.icrd1 - - 1], (ftnlen)-8)) == commvl_1.ivx) { - goto L11; - } -/* L10: */ - } -L11: - -/* Find outermost note, min or max depending on beam direction ulq. xto is true */ -/* if there's an ornament on that note. Expand orn list to include ._, since if */ -/* on extreme chord note in beam, will move. */ -/* So ornaments are all except 0,4,13 (,g,) */ - - levx = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; - xto = (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] * 24 - 1] - & 4186094) > 0; - icrdx = 0; - i__2 = comtrill_1.ncrd; - for (icrd = comtrill_1.icrd1; icrd <= i__2; ++icrd) { - if ((255 & comtrill_1.icrdat[icrd - 1]) != ip || (15 & - lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen)-8)) - != commvl_1.ivx) { - goto L13; - } - levc = 127 & lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen) - -12); - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] - == 'u' && levc > levx || *(unsigned char *)& - all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'l' && - levc < levx) { - levx = levc; - icrdx = icrd; - xto = (comtrill_1.icrdorn[icrd - 1] & 4186094) > 0; - } -/* L12: */ - } -L13: - -/* If there's orn on extreme note, do stuff */ - - if (xto) { - ++iorn; - if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] - == 'u') { - ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] + - all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1] - * comxtup_1.xelsk[inb - 1] / all_1.slfac - 1 + ( - multb - 1) * 1.2f; -/* Computing MAX */ - r__1 = ybeam + 3.f; - i__2 = i_nint(&r__1); - ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev); - } else { - ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] - - all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1] - * comxtup_1.xelsk[inb - 1] / all_1.slfac + 1 - ( - multb - 1) * 1.2f; -/* Computing MIN */ - r__1 = ybeam - 3.f; - i__2 = i_nint(&r__1), i__3 = nomornlev - 10; - ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3); - } - if (icrdx == 0) { - -/* Affected ornament is on main note */ - - all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set( - all_1.iornq[commvl_1.ivx + ip * 24 - 1],22); - } else { - comtrill_1.icrdorn[icrdx - 1] = bit_set( - comtrill_1.icrdorn[icrdx - 1],22); - } - } - } -L8: - ; - } - -/* Henceforth nornb will be a counter. */ - - if (iorn > 0) { - nornb[commvl_1.ivx] = 1; - } - if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) { - strtmid_1.ixrest[commvl_1.ivx - 1] = 0; - } - return 0; -} /* beamstrt_ */ - - - -/* meter space (pts) = xb4mbr = musicsize*facmtr */ - - -/* From other */ - -/* * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, */ - -/* Subroutine */ int catspace_(real *space, real *squez, integer *nnsk) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Local variables */ - static integer iptr; - - i__1 = c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1; - for (iptr = c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1]; iptr <= i__1; - ++iptr) { - if ((r__1 = *space - c1omnotes_1.durb[iptr - 1], dabs(r__1)) < - comtol_1.tol) { - if ((r__1 = *squez - c1omnotes_1.sqzb[iptr - 1], dabs(r__1)) < - comtol_1.tol) { - -/* Increment pre-existing entry */ - - c1omnotes_1.nnpd[iptr - 1] += *nnsk; - return 0; - } - } -/* L16: */ - } - -/* Didn't find current duration & squez, so add a new entry. */ -/* No particular reason to keep in order, so add at the end. */ - - c1omnotes_1.nnpd[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *nnsk; - c1omnotes_1.durb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *space; - c1omnotes_1.sqzb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *squez; - ++c1omnotes_1.nptr[c1omnotes_1.ibarcnt]; - return 0; -} /* catspace_ */ - -/* Character */ VOID chax_(char *ret_val, ftnlen ret_val_len, integer *n) -{ - -/* The only reason for this seemingly do-nothing function is to get around an */ -/* apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! */ - - *(unsigned char *)ret_val = (char) (*n); - return ; -} /* chax_ */ - -/* Subroutine */ int checkdyn_(char *lineq, integer *iccount, integer *ibar, - ftnlen lineq_len) -{ - /* System generated locals */ - address a__1[3]; - integer i__1, i__2[3], i__3; - real r__1; - char ch__1[4], ch__2[1]; - icilist ici__1; - - /* Builtin functions */ - integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *, - ftnlen, ftnlen); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void) - , i_nint(real *); - - /* Local variables */ - static integer ipm, iend; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer idno; - static real fnum; - static char durq[1]; - extern /* Subroutine */ int stop1_(void), errmsg_(char *, integer *, - integer *, char *, ftnlen, ftnlen); - static logical txtdyn; - extern /* Subroutine */ int readnum_(char *, integer *, char *, real *, - ftnlen, ftnlen); - static char dynsymq[4]; - - txtdyn = FALSE_; - -/* On entry, iccount is on "D" */ - - i__1 = *iccount; - if (s_cmp(lineq + i__1, "\"", *iccount + 1 - i__1, (ftnlen)1) == 0) { - -/* Dynamic text */ - - i__1 = *iccount + 1; - iend = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1); - if (iend == 0) { - i__1 = *iccount + 1; - errmsg_(lineq, &i__1, ibar, "Dynamic text must be terminated wit" - "h double quote!", (ftnlen)128, (ftnlen)50); - stop1_(); - } - -/* Set iccount to character after 2nd ", and set ipm */ - - *iccount = *iccount + iend + 2; - ipm = i_indx("- +", lineq + (*iccount - 1), (ftnlen)3, (ftnlen)1); - if (ipm == 0) { - errmsg_(lineq, iccount, ibar, "Expected \"-\", \"+\", or blank h" - "ere!", (ftnlen)128, (ftnlen)33); - stop1_(); - } - } else { - -/* Expect ordinary dynamic */ - - for (iend = *iccount + 2; iend <= 128; ++iend) { - ipm = i_indx("- +", lineq + (iend - 1), (ftnlen)3, (ftnlen)1); - if (ipm > 0) { - goto L2; - } -/* L1: */ - } -L2: - if (iend - *iccount > 5 || iend - *iccount < 2) { - i__1 = iend - 1; - errmsg_(lineq, &i__1, ibar, "Wrong length for dynamic mark!", ( - ftnlen)128, (ftnlen)30); - stop1_(); - } - i__1 = *iccount; - ici__1.icierr = 0; - ici__1.iciend = 0; - ici__1.icirnum = 1; - ici__1.icirlen = iend - 1 - i__1; - ici__1.iciunit = lineq + i__1; -/* Writing concatenation */ - i__2[0] = 2, a__1[0] = "(a"; - i__3 = iend + 47 - *iccount; - chax_(ch__2, (ftnlen)1, &i__3); - i__2[1] = 1, a__1[1] = ch__2; - i__2[2] = 1, a__1[2] = ")"; - ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1); - s_rsfi(&ici__1); - do_fio(&c__1, dynsymq, (ftnlen)4); - e_rsfi(); - idno = (i_indx("ppppppp pp p mp mf f fp sfz ff fff ffff< " - "> ", dynsymq, (ftnlen)56, (ftnlen)4) + 3) / 4; - if (idno == 0) { - i__1 = *iccount + 1; - errmsg_(lineq, &i__1, ibar, "Illegal dynamic mark!", (ftnlen)128, - (ftnlen)21); - stop1_(); - } - *iccount = iend; - } - if (ipm != 2) { - -/* There is a vertical shift, have "+" or "-" */ - - ++(*iccount); - if (i_indx("0123456789", lineq + (*iccount - 1), (ftnlen)10, (ftnlen) - 1) == 0) { - errmsg_(lineq, iccount, ibar, "Expected integer here for vertica" - "l offset!", (ftnlen)128, (ftnlen)42); - stop1_(); - } - readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); - idno = i_nint(&fnum); - if (idno > 63) { - i__1 = *iccount - 1; - errmsg_(lineq, &i__1, ibar, "Vertical offset for dynamic mark mu" - "st be (-63,63)!", (ftnlen)128, (ftnlen)50); - stop1_(); - } - ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1); - if (ipm == 0) { - errmsg_(lineq, iccount, ibar, "Expected \"+\", \"-\", or blank h" - "ere!", (ftnlen)128, (ftnlen)33); - stop1_(); - } - if (ipm != 2) { - -/* There is a horizontal shift */ - - ++(*iccount); - if (i_indx(".0123456789", lineq + (*iccount - 1), (ftnlen)11, ( - ftnlen)1) == 0) { - errmsg_(lineq, iccount, ibar, "Expected number here for hori" - "zontal offset!", (ftnlen)128, (ftnlen)43); - stop1_(); - } - readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); - r__1 = fnum * 10; - idno = i_nint(&r__1); - if (idno > 255) { - i__1 = *iccount - 1; - errmsg_(lineq, &i__1, ibar, "Horizontal offset for dynamic m" - "ark must be (-25.5,25.5)!", (ftnlen)128, (ftnlen)56); - stop1_(); - } else if (*(unsigned char *)durq != ' ') { - errmsg_(lineq, iccount, ibar, "There should be a blank here!", - (ftnlen)128, (ftnlen)29); - stop1_(); - } - } - -/* iccount should be on the blank at the end of the entire symbol */ - - } - return 0; -} /* checkdyn_ */ - -/* Subroutine */ int chkarp_(integer *ncrd, integer *icrdat, integer *ivx, - integer *ip, logical *iscacc, logical *isarp) -{ - /* System generated locals */ - integer i__1; - - /* Builtin functions */ - integer lbit_shift(integer, integer); - - /* Local variables */ - static integer icrd; - static logical found1; - -/* subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, */ -/* * icashft) */ - /* Parameter adjustments */ - --icrdat; - - /* Function Body */ - found1 = FALSE_; - -/* icashft will be max left shift of accid's in chord notes. */ -/* Used only for spacing checks. */ -/* Will include left shift of chord note itself. */ -/* Rezero after use. */ - - i__1 = *ncrd; - for (icrd = 1; icrd <= i__1; ++icrd) { - -/* This if block cycles thru all chord notes on ivx,ip; then returns. */ - - if ((255 & icrdat[icrd]) == *ip && (15 & lbit_shift(icrdat[icrd], ( - ftnlen)-8)) == *ivx) { - found1 = TRUE_; - *iscacc = *iscacc || bit_test(icrdat[icrd],19) && ! bit_test( - icrdat[icrd],27); - -/* Accid on this chord note, and it's not midi-only. */ - -/* irshft = igetbits(icrdot(icrd),7,20) */ -/* c */ -/* c Include increment for notehead shift */ -/* c */ -/* if (btest(icrdat(icrd),23)) then */ -/* if (irshft .eq. 0) then */ -/* irshft = 44 */ -/* else */ -/* irshft=irshft-20 */ -/* end if */ -/* end if */ -/* if (irshft .ne. 0) then */ -/* c */ -/* c Accid on chord note is shifted. Include only left shift, in 20ths. */ -/* c */ -/* if (irshft .lt. 64) icashft = max(icashft,64-irshft) */ -/* end if */ -/* end if */ - *isarp = *isarp || bit_test(icrdat[icrd],25); - } else if (found1) { - return 0; - } -/* L18: */ - } - return 0; -} /* chkarp_ */ - -/* Subroutine */ int chkimidi_(integer *icm) -{ - /* Builtin functions */ - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), - e_wsfe(void); - - /* Fortran I/O blocks */ - static cilist io___231 = { 0, 6, 0, 0, 0 }; - static cilist io___232 = { 0, 6, 0, 0, 0 }; - static cilist io___233 = { 0, 6, 0, "(a6,2x,4i8)", 0 }; - - - if (commidi_1.imidi[*icm] >= 24576) { - s_wsle(&io___231); - e_wsle(); - s_wsle(&io___232); - do_lio(&c__9, &c__1, "Midi file is too long! It will be corrupted or" - " worse", (ftnlen)52); - e_wsle(); - s_wsfe(&io___233); - do_fio(&c__1, "imidi:", (ftnlen)6); - do_fio(&c__1, (char *)&commidi_1.imidi[0], (ftnlen)sizeof(integer)); - do_fio(&c__1, (char *)&commidi_1.imidi[1], (ftnlen)sizeof(integer)); - do_fio(&c__1, (char *)&commidi_1.imidi[2], (ftnlen)sizeof(integer)); - do_fio(&c__1, (char *)&commidi_1.imidi[3], (ftnlen)sizeof(integer)); - e_wsfe(); - } - return 0; -} /* chkimidi_ */ - -/* Subroutine */ int chklit_(char *lineq, integer *iccount, integer *literr, - ftnlen lineq_len) -{ - /* System generated locals */ - char ch__1[1]; - - /* Local variables */ - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static char charq[1]; - static integer itype, lenlit; - extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen, - ftnlen); - - *literr = 0; - itype = 1; -L17: - g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); - chax_(ch__1, (ftnlen)1, &c__92); - if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) { - ++itype; -/* if (itype .eq. 2) then */ -/* if (iccount .ne. 2 ) then */ -/* c */ -/* c type 2 or 3 tex string not starting in column 1 */ -/* c */ -/* literr = 3 */ -/* return */ -/* end if */ -/* else if (itype .gt. 3) then */ - if (itype > 3) { - *literr = 1; - return 0; - } - goto L17; - } - lenlit = itype; -L18: - g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); - chax_(ch__1, (ftnlen)1, &c__92); - if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) { - g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)charq != ' ') { - -/* Starting a new tex command withing the string */ - - lenlit += 2; - if (lenlit > 128) { - *literr = 2; - return 0; - } - goto L18; - } - } else { - ++lenlit; - if (lenlit > 128) { - *literr = 2; - return 0; - } - goto L18; - } - return 0; -} /* chklit_ */ - -/* Subroutine */ int chkpm4ac_(char *lineq, integer *iccount, integer *nacc, - logical *moved, ftnlen lineq_len) -{ - /* System generated locals */ - integer i__1, i__2; - real r__1; - - /* Builtin functions */ - integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *, - ftnlen, ftnlen), i_nint(real *); - - /* Local variables */ - static integer ipm; - static real fnum; - static char durq[1]; - static integer icsav; - static logical ishorz; - extern /* Subroutine */ int readnum_(char *, integer *, char *, real *, - ftnlen, ftnlen), setbits_(integer *, integer *, integer *, - integer *); - - -/* Called after getting +/-/ in a note (not rest). iccount is on the +-<>. */ -/* Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits */ -/* 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed */ -/* numbers. If moved=.true., iccount on exit is on end of last number. */ -/* If moved=.false., iccount still on +/- */ - - i__1 = *iccount - 2; - i__2 = *iccount; - if (i_indx("sfnA", lineq + i__1, (ftnlen)4, *iccount - 1 - i__1) > 0 && - i_indx("0123456789.", lineq + i__2, (ftnlen)11, *iccount + 1 - - i__2) > 0) { - -/* Prior char was accid & next is #; this may be start of accidental shift. */ -/* Must test for "." above in case we get "<" or ">" */ - - ipm = i_indx("- +< >", lineq + (*iccount - 1), (ftnlen)6, (ftnlen)1) - - 2; - i__1 = *iccount + 1; - i__2 = *iccount; - if (s_cmp(lineq + i__2, ".", *iccount + 1 - i__2, (ftnlen)1) == 0 && - i_indx("0123456789", lineq + i__1, (ftnlen)10, *iccount + 2 - - i__1) == 0) { - -/* Rare case of [accid][+/-].[letter]. Bail out */ - - *moved = FALSE_; - return 0; - } - ishorz = ipm > 1; - -/* Save iccount in case it's not accid shift and we have to reset. */ - - icsav = *iccount; - ++(*iccount); - readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); - if (ishorz || i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* This has to be accidental shift. Set vert. shift. */ - - if (! ishorz) { - -/* +/- syntax, both shifts set, vertical first */ - - i__1 = (integer) (ipm * fnum + 32.5f); - setbits_(nacc, &c__6, &c__4, &i__1); - ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) - 2; - ++(*iccount); - readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); - } else { - -/* syntax, only horiz set */ - - ipm += -3; - } - -/* Set horiz. shift */ - - r__1 = (ipm * fnum + 5.35f) * 20; - i__1 = i_nint(&r__1); - setbits_(nacc, &c__7, &c__10, &i__1); - --(*iccount); - *moved = TRUE_; - } else { - -/* False alarm. Reset everything and flow onward */ - - *moved = FALSE_; - *iccount = icsav; - } - } else { - -/* Either prior char was not 'sfn' or next was not digit, so take no action */ - - *moved = FALSE_; - } - return 0; -} /* chkpm4ac_ */ - -/* Subroutine */ int clefsym_(integer *isl, char *notexq, integer *lnote, - integer *nclef, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[4]; - integer i__1[4], i__2, i__3; - char ch__1[1], ch__2[1], ch__3[1]; - - /* Builtin functions */ - integer lbit_shift(integer, integer); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer nlev; - - -/* Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. */ - - *nclef = lbit_shift(*isl, (ftnlen)-12) & 7; - if (*nclef == 0) { - -/* treble */ - - nlev = 2; - } else if (*nclef > 6) { - -/* French violin */ - - nlev = 0; - } else if (*nclef < 5) { - -/* C-clef */ - - nlev = (*nclef << 1) - 2; - } else { - -/* F-clef */ - - nlev = (*nclef << 1) - 6; - } -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__1[0] = 1, a__1[0] = ch__1; - i__1[1] = 7, a__1[1] = "pmxclef"; - i__2 = min(*nclef,7) + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__1[2] = 1, a__1[2] = ch__2; - i__3 = nlev + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__1[3] = 1, a__1[3] = ch__3; - s_cat(notexq, a__1, i__1, &c__4, notexq_len); - *lnote = 10; - return 0; -} /* clefsym_ */ - -/* Subroutine */ int crdacc_(integer *nacc, integer *naccid, integer *micrd, - integer *nolevm, real *rmsshift, logical *lasttime, integer * - levmaxacc, integer *icrdot0, real *segrb0, integer *ksegrb0, integer * - nsegrb0, logical *twooftwo, integer *icashft) -{ - /* Initialized data */ - - static integer nsegar[5] = { 3,4,3,3,2 }; - static integer nsegal[5] = { 2,4,3,3,2 }; - static real segar[60] /* was [5][2][6] */ = { -.05f,-.38f,-.34f, - -.05f,-.15f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,-.75f,-.2f,-.8f,-.75f, - 0.f,.96f,-1.04f,1.48f,.96f,1.2f,0.f,-.38f,0.f,0.f,0.f,3.15f,1.64f, - 3.f,3.15f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f,0.f, - 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f, - 0.f,0.f }; - static real segal[60] /* was [5][2][6] */ = { -1.f,-1.02f,-.6f, - -1.65f,-1.2f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,0.f,-1.2f,-1.04f,0.f, - 0.f,3.15f,-1.64f,-1.48f,3.15f,1.2f,0.f,-1.02f,0.f,0.f,0.f,0.f, - 1.04f,3.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f, - 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f, - 0.f,0.f,0.f }; - static integer iacctbl[6] = { 1,2,3,0,4,5 }; - - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1; - - /* Builtin functions */ - integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, - char *, ftnlen), e_wsle(void); - - /* Local variables */ - static integer iacctype; - static logical mainnote; - extern integer igetbits_(integer *, integer *, integer *); - static real ybotaseg, shiftmin; - static integer isetshft[10]; - static real ytopaseg; - static integer ibelowbot, ibelowtop, iwa, iranksetter, iseg; - extern /* Subroutine */ int stop1_(void); - static integer isega; - static real segrb[100] /* was [2][50] */; - static integer irank; - static real shift; - static integer nolev, isegrb, ksegrb[50], nsegrb, ishift; - extern /* Subroutine */ int printl_(char *, ftnlen); - static integer netgain; - extern /* Subroutine */ int setbits_(integer *, integer *, integer *, - integer *); - - /* Fortran I/O blocks */ - static cilist io___268 = { 0, 6, 0, 0, 0 }; - static cilist io___269 = { 0, 6, 0, 0, 0 }; - - - -/* nacc = accidental bitmap for main note */ -/* naccid = # of accid's in chord */ -/* micrd = array with icrd #'s for notes w/ acc's, 0=>main note */ -/* nolevm = level of main note */ -/* segrb(1|2,.) x|y-coord of right-bdry segment */ -/* ksegrb(.) internal use; tells what defined this segment */ -/* -2: Left-shifted notehead */ -/* -1: Original right boundary */ -/* 0: Main note accidental */ -/* icrd: Chord-note accidental */ -/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */ -/* icrdot0 = top-down level-rank of main note among accid-notes */ -/* icrdot(icrd)(27-29) = level rank of chord-note among accid-notes */ -/* twooftwo will be true 2nd time thru; signal to store shifts w/ notes */ - - /* Parameter adjustments */ - --ksegrb0; - segrb0 -= 3; - --micrd; - - /* Function Body */ - -/* Fancy sharp boundary. fl,sh,na,dfl,dsh */ - -/* * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , */ -/* meas value for y, natural is 1.6 */ -/* * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , */ -/* c (meas. value is 3.08) ^^^^ */ -/* c Raise top of flat so it interferes with bottom of sharp */ - -/* iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) */ - - -/* Set up barrier segrb(iseg,ipoint) to define coords of corner points */ -/* on stem+notes */ - - i__1 = *nsegrb0; - for (iseg = 1; iseg <= i__1; ++iseg) { - segrb[(iseg << 1) - 2] = segrb0[(iseg << 1) + 1]; - segrb[(iseg << 1) - 1] = segrb0[(iseg << 1) + 2]; - ksegrb[iseg - 1] = ksegrb0[iseg]; -/* L11: */ - } - nsegrb = *nsegrb0; - *rmsshift = 0.f; - shiftmin = 1e3f; - i__1 = *naccid; - for (iwa = 1; iwa <= i__1; ++iwa) { - -/* Initialize shift for this note */ - - shift = 0.f; - mainnote = micrd[iwa] == 0; - isetshft[iwa - 1] = -1; - -/* Get note level and accidental type */ - - if (mainnote) { - nolev = *nolevm; - iacctype = iacctbl[igetbits_(nacc, &c__3, &c__0) - 1]; - } else { - nolev = igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], &c__7, & - c__12); - iacctype = iacctbl[igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], & - c__3, &c__20) - 1]; - } - -/* Cycle thru segments on right edge of this accidental */ - - i__2 = nsegar[iacctype - 1] - 1; - for (isega = 1; isega <= i__2; ++isega) { - ybotaseg = nolev + segar[iacctype + ((isega << 1) + 2) * 5 - 16]; - ytopaseg = nolev + segar[iacctype + ((isega + 1 << 1) + 2) * 5 - - 16]; - -/* Cycle thru segments of right-hand barrier */ - - i__3 = nsegrb - 1; - for (isegrb = 1; isegrb <= i__3; ++isegrb) { - -/* Must find all barrier segments that start below ytopseg & end above ybotseg */ - - if (segrb[(isegrb << 1) - 1] < ytopaseg) { - -/* Barrier seg starts below top of accid */ -/* Check if barrier seg ends above bottom of accid */ - - if (segrb[(isegrb + 1 << 1) - 1] > ybotaseg) { - if (shift > segrb[(isegrb << 1) - 2] - segar[iacctype - + ((isega << 1) + 1) * 5 - 16]) { - shift = segrb[(isegrb << 1) - 2] - segar[iacctype - + ((isega << 1) + 1) * 5 - 16]; - -/* Record the cause of the shift */ - - isetshft[iwa - 1] = ksegrb[isegrb - 1]; - } - } - -/* Does barrier segment end above top of accid seg? */ - - if (segrb[(isegrb + 1 << 1) - 1] > ytopaseg) { - goto L4; - } - } -/* L3: */ - } -L4: -/* L2: */ - ; - } - if (! bit_test(*nacc,28) && dabs(shift) > 1e-4f && ! (*lasttime)) { -/* if (nolev .eq. levmaxacc) then */ - if (nolev == *levmaxacc && isetshft[iwa - 1] == -1) { - *rmsshift = 1e3f; - return 0; - } - -/* Does the following properly account for left-shifted noteheads? */ - -/* Top-down rank of this note we just shifted */ - - if (mainnote) { - irank = *icrdot0; - } else { - irank = igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__3, & - c__27); - } - -/* Compare level-rank of this note vs. that of note that caused the shift. */ -/* This has effect of checking for basic interferences from top down. */ - -/* ksegrb(.) internal use; tells what defined this segment */ -/* -2: Left-shifted notehead */ -/* -1: Original right boundary */ -/* 0: Main note accidental */ -/* icrd: Chord-note accidental */ -/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */ - - if (isetshft[iwa - 1] < 0) { - iranksetter = 0; - } else if (isetshft[iwa - 1] == 0) { - iranksetter = *icrdot0; - } else { - iranksetter = igetbits_(&comtrill_1.icrdot[isetshft[iwa - 1] - - 1], &c__3, &c__27); - } - if (iranksetter != 0 && irank != iranksetter + 1) { - *rmsshift = 1e3f; - return 0; - } - } -/* Computing 2nd power */ - r__1 = shift; - *rmsshift += r__1 * r__1; - if (*lasttime && dabs(shift) > 1e-4f) { - if (mainnote) { - if (! bit_test(*nacc,29)) { - goto L10; - } - } else { - if (! bit_test(comtrill_1.icrdat[micrd[iwa] - 1],29)) { - goto L10; - } - } - -/* If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there */ -/* was a manual shift but auto-shift was zero, will not come thru here, but shift value */ -/* will be left intact. */ - - if (mainnote) { - shift += (igetbits_(nacc, &c__7, &c__10) - 107) * .05f; - } else { - shift += (igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7, - &c__20) - 107) * .05f; - } -L10: - if (*twooftwo) { - -/* Record the shift for this accidental */ - - if (shift < -5.35f) { - printl_(" ", (ftnlen)1); - printl_("WARNING: auto-generated accidental shift too bi" - "g for PMX, ignoring", (ftnlen)66); - } else { - r__1 = (shift + 5.35f) * 20; - ishift = i_nint(&r__1); - if (mainnote) { - setbits_(nacc, &c__7, &c__10, &ishift); - } else { - setbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7, & - c__20, &ishift); - } - } - } else { - -/* This is the earlier call to precrd, so need minimum shift */ - - shiftmin = dmin(shiftmin,shift); - } - } - -/* Bail out if this is the last accidental to check */ - - if (iwa == *naccid) { - goto L1; - } - -/* Add this accidental to the right barrier! Count down from highest barrier segment, */ -/* find 1st one starting below top of accid, and first one starting below bot. */ - - for (ibelowtop = nsegrb; ibelowtop >= 1; --ibelowtop) { - if (segrb[(ibelowtop << 1) - 1] < nolev + segal[iacctype + (( - nsegal[iacctype - 1] << 1) + 2) * 5 - 16]) { - for (ibelowbot = ibelowtop; ibelowbot >= 1; --ibelowbot) { - if (segrb[(ibelowbot << 1) - 1] < nolev + segal[iacctype - + 4]) { - goto L6; - } -/* L9: */ - } - s_wsle(&io___268); - do_lio(&c__9, &c__1, "Oops2!", (ftnlen)6); - e_wsle(); - stop1_(); - } -/* L5: */ - } - s_wsle(&io___269); - do_lio(&c__9, &c__1, "Ugh0! in crdaccs", (ftnlen)16); - e_wsle(); - stop1_(); -L6: - netgain = nsegal[iacctype - 1] - ibelowtop + ibelowbot; - -/* Shift high segments up */ - - if (netgain >= 0) { - i__2 = ibelowtop + 1; - for (isegrb = nsegrb; isegrb >= i__2; --isegrb) { - segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2]; - segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1]; - ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1]; -/* L7: */ - } - -/* Set up 1st segment above accid */ - - segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) - - 2]; - segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + ( - (nsegal[iacctype - 1] << 1) + 2) * 5 - 16]; - ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1]; - } else { - -/* netgain<0, must remove segments. Use same coding but reverse order, */ -/* work from bottom up */ - - segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) - - 2]; - segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + ( - (nsegal[iacctype - 1] << 1) + 2) * 5 - 16]; - ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1]; - i__2 = nsegrb; - for (isegrb = ibelowtop + 1; isegrb <= i__2; ++isegrb) { - segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2]; - segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1]; - ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1]; -/* L12: */ - } - } - -/* Insert new segments */ - - i__2 = nsegal[iacctype - 1] - 1; - for (isega = 1; isega <= i__2; ++isega) { - segrb[(ibelowbot + isega << 1) - 2] = shift + segal[iacctype + (( - isega << 1) + 1) * 5 - 16]; - segrb[(ibelowbot + isega << 1) - 1] = nolev + segal[iacctype + (( - isega << 1) + 2) * 5 - 16]; - if (mainnote) { - ksegrb[ibelowbot + isega - 1] = 0; - } else { - ksegrb[ibelowbot + isega - 1] = micrd[iwa]; - } -/* L8: */ - } - -/* Update number of barrier segments */ - - nsegrb += netgain; -/* c */ -/* c Temporary printout for boundary segments as built up */ -/* c */ -/* write(15,'()') */ -/* write(15,'(a/(2f8.2,i5))')' y x kseg', */ -/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */ -/* write(15,'(a/(2i5))')' micrd isetshft', */ -/* * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) */ -/* c */ -L1: - ; - } -/* next accidental */ - if (*lasttime && ! (*twooftwo)) { - -/* This is the final call on the pre-ask pass, so compute left-shift rqmt. */ - - r__1 = shiftmin * -20; - *icashft = i_nint(&r__1); - } -/* c */ -/* c Temporary printout for boundary segments */ -/* c */ -/* if (twooftwo) then */ -/* write(15,'()') */ -/* write(15,'(a/(2f8.2,i5))')' y x kseg', */ -/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */ -/* write(15,'(a/(2i5))')' micrd isetshft', */ -/* * (micrd(iwa),isetshft(iwa),iwa=1,naccid) */ -/* end if */ -/* c */ - return 0; -} /* crdacc_ */ - -/* Subroutine */ int crdaccs_(integer *nacc, integer *ipl, integer *irest, - integer *naccid, integer *kicrd, integer *nolevm, integer *levmaxacc, - integer *levminacc, integer *icrdot0, logical *twooftwo, integer * - icashft) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - - /* Local variables */ - extern integer igetbits_(integer *, integer *, integer *); - static integer ipermsav[7]; - static real rmsshift; - static integer i__, j, k, levmidacc, ip, ir, is, it, maxmanshft, icrd; - extern /* Subroutine */ int stop1_(void); - static integer micrd[10], iiseg, irank, iperm[7], nolev; - static real segrb0[100] /* was [2][50] */; - extern /* Subroutine */ int crdacc_(integer *, integer *, integer *, - integer *, real *, logical *, integer *, integer *, real *, - integer *, integer *, logical *, integer *); - static logical tagged; - static integer isegrb; - static logical manual, lshift; - static integer idummy; - static real rmsmin; - static integer ksegrb0[50], nsegrb0, manshft; - extern /* Subroutine */ int setbits_(integer *, integer *, integer *, - integer *); - - /* Fortran I/O blocks */ - static cilist io___298 = { 0, 6, 0, 0, 0 }; - - - -/* nacc = accidental bitmap for main note */ -/* naccid = # of accid's in chord */ -/* kicrd = array with icrd #'s for notes w/ acc's, 0=>main note */ -/* nolevm = level of main note */ - -/* This is called once per multi-accidental chord. In here, loop over all */ -/* permutations of the order of accidental as stored in kicrd. Each time thru */ -/* loop, call crdacc once, get rms shift. Only save permutation and rms value */ -/* if it is less than old value. */ - - -/* Make consistent? 120106 */ -/* integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) */ -/* c */ -/* c Temporary printout of level-rankings */ -/* c */ -/* write(15,'()') */ -/* do 98 iacc = 1 , naccid */ -/* if (kicrd(iacc) .eq. 0) then */ -/* write(15,'(3i5)')nolevm,icrdot0 */ -/* else */ -/* write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), */ -/* * igetbits(icrdot(kicrd(iacc)),3,27) */ -/* end if */ -/* 98 continue */ -/* c */ - -/* Initialize right-barrier */ - - /* Parameter adjustments */ - --kicrd; - - /* Function Body */ - segrb0[0] = 0.f; - segrb0[1] = -1e3f; - segrb0[2] = 0.f; - segrb0[3] = 1e3f; - nsegrb0 = 2; - ksegrb0[0] = -1; - ksegrb0[1] = -1; - -/* Search for left-shifted notes, Make up the initial right-barrier, which */ -/* will be good for all permutations. */ -/* irest()(27) is set if any notes are left-shifted */ -/* Must use ALL chord notes, not just ones w/ accid's. */ - - if (bit_test(*irest,27)) { - i__1 = comtrill_1.icrd2; - for (icrd = comtrill_1.icrd1 - 1; icrd <= i__1; ++icrd) { - if (icrd == comtrill_1.icrd1 - 1) { - -/* Main note */ - -/* lshift = btest(ipl,8) */ - lshift = bit_test(*ipl,8) || bit_test(*nacc,31); - if (lshift) { - nolev = *nolevm; - } - } else { - -/* Chord note */ - - lshift = bit_test(comtrill_1.icrdat[icrd - 1],23); -/* if (lshift) nolev = igetbits(icrdat(icrd),7,12) */ - if (lshift) { - nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, & - c__12); - if (bit_test(*nacc,31) && nolev == *nolevm + 1) { - -/* This note is not really shifted, It is the upper of a 2nd with the main */ -/* note on an upstem, and Main note must be shifted. */ -/* nacc(31) signals the real truth. */ - - lshift = FALSE_; - } - } - } - if (lshift) { - i__2 = nsegrb0 - 1; - for (isegrb = 1; isegrb <= i__2; ++isegrb) { - if (segrb0[(isegrb + 1 << 1) - 1] > (real) (nolev - 1)) { - -/* Add this notehead to the right boundary here. Move all higher segs up 2. */ - - i__3 = isegrb + 1; - for (iiseg = nsegrb0; iiseg >= i__3; --iiseg) { - segrb0[(iiseg + 2 << 1) - 2] = segrb0[(iiseg << 1) - - 2]; - segrb0[(iiseg + 2 << 1) - 1] = segrb0[(iiseg << 1) - - 1]; - ksegrb0[iiseg + 1] = ksegrb0[iiseg - 1]; -/* L17: */ - } - goto L18; - } -/* L16: */ - } -L18: - -/* Insert notehead into list. Set kseg=-2 to signal notehead shift. */ - - iiseg = isegrb + 1; - segrb0[(iiseg << 1) - 2] = -1.2f; - segrb0[(iiseg << 1) - 1] = nolev - 1.f; - ksegrb0[iiseg - 1] = -2; - segrb0[(iiseg + 1 << 1) - 2] = 0.f; - segrb0[(iiseg + 1 << 1) - 1] = nolev + 1.f; - ksegrb0[iiseg] = -1; - nsegrb0 += 2; - } -/* L15: */ - } - } - -/* Done setting right barrier for left-shifted noteheads */ - - tagged = FALSE_; - manual = FALSE_; - -/* Preprocess to check for manual shifts. */ -/* If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then */ -/* If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then */ -/* 1. Auto-shifting proceeds */ -/* 2. "A"-shifts add to autoshifts */ -/* 3. non-"A" shifts are ignored! */ -/* Else (>0 man shifts, none has "A") */ -/* No auto-ordering, No autoshifts, Observe all manual shifts. */ -/* End if */ -/* End if */ - - maxmanshft = 0; - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - if (kicrd[i__] == 0) { - -/* Main note */ - - manshft = igetbits_(nacc, &c__7, &c__10); - if (manshft != 0) { - manual = TRUE_; - if (bit_test(*nacc,29)) { - tagged = TRUE_; - } else { -/* maxmanshft = max(maxmanshft,64-manshft) */ -/* Computing MAX */ - i__2 = maxmanshft, i__3 = 107 - manshft; - maxmanshft = max(i__2,i__3); - } - } - } else { - -/* Chord note */ - - manshft = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, & - c__20); - if (manshft != 0) { - manual = TRUE_; - if (bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) { - tagged = TRUE_; - } else { -/* maxmanshft = max(maxmanshft,64-manshft) */ -/* Computing MAX */ - i__2 = maxmanshft, i__3 = 107 - manshft; - maxmanshft = max(i__2,i__3); - } - } - } -/* L13: */ - } - if (manual) { - if (tagged) { - -/* zero out all untagged shifts */ - - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - if (kicrd[i__] == 0) { - if (! bit_test(*nacc,29)) { - setbits_(nacc, &c__7, &c__10, &c__0); - } - } else { - if (! bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) { - setbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, & - c__20, &c__0); - } - } -/* L14: */ - } - } else { - -/* There are manual shifts but none tagged. Only proceed if "Ao" was entered */ - - if (! bit_test(*nacc,28)) { - *icashft = maxmanshft; - return 0; - } - } - } - if (bit_test(*nacc,28)) { - -/* Take the accidentals in order as originally input, then exit. */ - - crdacc_(nacc, naccid, &kicrd[1], nolevm, &rmsshift, &c_true, &idummy, - &idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); - return 0; -/* end if */ - } else if (*naccid == 3) { - -/* Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd */ -/* then place in order top, bottom, middle. */ - - for (i__ = 1; i__ <= 3; ++i__) { - if (kicrd[i__] == 0) { - irank = *icrdot0; - nolev = *nolevm; - } else { - irank = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__3, & - c__27); - nolev = igetbits_(&comtrill_1.icrdat[kicrd[i__] - 1], &c__7, & - c__12); - } - if (irank == 1) { - micrd[0] = kicrd[i__]; - } else { - micrd[5 - irank - 1] = kicrd[i__]; - } - if (irank == 2) { - levmidacc = nolev; - } -/* L20: */ - } - if (*levmaxacc != levmidacc + 1 && levmidacc != *levminacc + 1) { - crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy, - &idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); - return 0; - } - } - rmsmin = 1e5f; - -/* Initialize permutation array */ - - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - iperm[i__ - 1] = i__; -/* L7: */ - } - -/* Start looping over permutations */ - - for (ip = 1; ip <= 5041; ++ip) { - if (ip != 1) { - -/* Work the magic algorithm to get the next permutation */ - - for (k = *naccid - 1; k >= 1; --k) { - if (iperm[k - 1] <= iperm[k]) { - goto L2; - } -/* L1: */ - } - -/* If here, we just got the last permutation, so exit the loop over permutations */ - - goto L10; -L2: - for (j = *naccid; j >= 1; --j) { - if (iperm[k - 1] <= iperm[j - 1]) { - goto L4; - } -/* L3: */ - } -L4: - it = iperm[j - 1]; - iperm[j - 1] = iperm[k - 1]; - iperm[k - 1] = it; - is = k + 1; - for (ir = *naccid; ir >= 1; --ir) { - if (ir <= is) { - goto L6; - } - it = iperm[ir - 1]; - iperm[ir - 1] = iperm[is - 1]; - iperm[is - 1] = it; - ++is; -/* L5: */ - } -L6: - ; - } - -/* New we have a permutation. Take icrd values out of kicrd and put them into */ -/* micrd in the order of the permutation */ - - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - micrd[i__ - 1] = kicrd[iperm[i__ - 1]]; -/* L9: */ - } -/* c */ -/* c Temporary printout */ -/* c */ -/* write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) */ -/* c */ - crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_false, levmaxacc, - icrdot0, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); -/* c */ -/* c Temporary printout */ -/* c */ -/* write(15,*)'perm done, rmsshift:',rmsshift */ -/* c */ - if (rmsshift < rmsmin) { - -/* Save this permutation, reset minrms */ - - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - ipermsav[i__ - 1] = iperm[i__ - 1]; - rmsmin = rmsshift; -/* L11: */ - } - } -/* L8: */ - } - s_wsle(&io___298); - do_lio(&c__9, &c__1, "Should not BEEEEEE here!", (ftnlen)24); - e_wsle(); - stop1_(); -L10: - -/* Done looping, get info for the final choice */ - - i__1 = *naccid; - for (i__ = 1; i__ <= i__1; ++i__) { - micrd[i__ - 1] = kicrd[ipermsav[i__ - 1]]; -/* L12: */ - } -/* c */ -/* c Temporary printout */ -/* c */ -/* write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) */ -/* c */ - crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy, &idummy, - segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); - return 0; -} /* crdaccs_ */ - -/* Subroutine */ int doacc_(integer *ihshft, integer *ivshft, char *notexq, - integer *lnote, integer *nacc, integer *nolev, integer *ncm, logical * - caut, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[2], a__2[3]; - integer i__1[2], i__2[3]; - char ch__1[1]; - icilist ici__1; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) - ; - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - static char sq[1]; - static integer lacc; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static real hshft; - static char noteq[8]; - extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen); - static integer noleva; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static char acsymq[3]; - static integer lnoten; - - chax_(ch__1, (ftnlen)1, &c__92); - *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; - if (*ihshft == -107) { - *ihshft = 0; - } -/* c */ -/* c If main note shifted left, so shift accid. Terminate below, when acc. is done. */ -/* c */ - if (*ihshft != 0) { - -/* Accid must be shifted horizontally */ - - if (*ihshft < 0) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = sq; - i__1[1] = 8, a__1[1] = "loffset{"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - *ihshft = -(*ihshft); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = sq; - i__1[1] = 8, a__1[1] = "roffset{"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - } - hshft = *ihshft * .05f; - if (hshft < 1.f) { - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 3; - ici__1.iciunit = notexq + 9; - ici__1.icifmt = "(f3.2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real)); - e_wsfi(); - *lnote = 12; - } else { - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 4; - ici__1.iciunit = notexq + 9; - ici__1.icifmt = "(f4.2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real)); - e_wsfi(); - *lnote = 13; - } -/* Writing concatenation */ - i__2[0] = *lnote, a__2[0] = notexq; - i__2[1] = 2, a__2[1] = "}{"; - i__2[2] = 1, a__2[2] = sq; - s_cat(notexq, a__2, i__2, &c__3, (ftnlen)79); - *lnote += 3; - } else { - s_copy(notexq, sq, (ftnlen)79, (ftnlen)1); - *lnote = 1; - } - if (bit_test(*nacc,3)) { -/* Writing concatenation */ - i__1[0] = *lnote, a__1[0] = notexq; - i__1[1] = 3, a__1[1] = "big"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - *lnote += 3; - } - if (*caut) { - -/* Cautionary accidental. Need to define bigcna,... in pmx.tex */ - -/* Writing concatenation */ - i__1[0] = *lnote, a__1[0] = notexq; - i__1[1] = 1, a__1[1] = "c"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - ++(*lnote); - } - accsym_(nacc, acsymq, &lacc, (ftnlen)3); -/* Writing concatenation */ - i__1[0] = *lnote, a__1[0] = notexq; - i__1[1] = lacc, a__1[1] = acsymq; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - *lnote += lacc; - noleva = *nolev; - if (*ivshft != 0) { - noleva = noleva + *ivshft - 32; - } - notefq_(noteq, &lnoten, &noleva, ncm, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } -/* Writing concatenation */ - i__1[0] = *lnote, a__1[0] = notexq; - i__1[1] = lnoten, a__1[1] = noteq; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - *lnote += lnoten; - if (*ihshft != 0) { - -/* Terminate horizontal shift */ - -/* Writing concatenation */ - i__1[0] = *lnote, a__1[0] = notexq; - i__1[1] = 1, a__1[1] = "}"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - ++(*lnote); - } - return 0; -} /* doacc_ */ - -/* Subroutine */ int docrd_(integer *ivx, integer *ip, integer *nodu, integer - *ncm, integer *iv, real *tnow, char *soutq, integer *lsout, char *ulq, - integer *ibmcnt, integer *islur, integer *nvmx, integer *nv, logical - *beamon, integer *nolevm, integer *ihornb, integer *nornb, real * - stemlen, logical *dotxtup, integer *nacc, ftnlen soutq_len, ftnlen - ulq_len) -{ - /* System generated locals */ - address a__1[2]; - integer i__1, i__2, i__3[2], i__4, i__5, i__6; - logical L__1; - char ch__1[1]; - - /* Builtin functions */ - integer pow_ii(integer *, integer *), lbit_shift(integer, integer); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), - s_copy(char *, char *, ftnlen, ftnlen); - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - extern integer igetbits_(integer *, integer *, integer *); - static integer kv; - extern integer log2_(integer *); - static integer icrd; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer lout, lsym; - static char outq[79]; - extern /* Subroutine */ int stop1_(void), doacc_(integer *, integer *, - char *, integer *, integer *, integer *, integer *, logical *, - ftnlen); - extern integer ncmid_(integer *, integer *); - static integer lnote, nolev; - static char noteq[8]; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen); - static integer nactmp; - static logical isleft; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static real updotc, rtdotc; - static integer lnoten, nolevo; - extern /* Subroutine */ int dotmov_(real *, real *, char *, integer *, - integer *, ftnlen), putarp_(real *, integer *, integer *, integer - *, integer *, char *, integer *, ftnlen); - static char notexq[79], nosymq[7]; - extern /* Subroutine */ int putorn_(integer *, integer *, integer *, - integer *, integer *, char *, integer *, integer *, integer *, - integer *, integer *, integer *, integer *, real *, char *, - integer *, integer *, integer *, logical *, logical *, ftnlen, - ftnlen), addmidi_(integer *, integer *, integer *, integer *, - real *, logical *, logical *); - static logical isright; - extern /* Subroutine */ int setbits_(integer *, integer *, integer *, - integer *); - - /* Fortran I/O blocks */ - static cilist io___323 = { 0, 6, 0, 0, 0 }; - static cilist io___324 = { 0, 6, 0, 0, 0 }; - - - - - -/* This subr. once produced notexq for entire chord. 10/18/97 altered to write */ -/* chord notes as we go. 10/22/97 find range of icrd first. */ -/* 2/25/98 moved rangefinding to precrd so done before slurs, so now */ -/* on entry, icrd1, icrd2 define range of icrd for this chord. */ - -/* Set counter (for this note) for chord notes present. Set notmain=T. */ -/* Will test for notmain=.true. in addmidi to tell whether to save pitch. */ - - /* Parameter adjustments */ - --nornb; - ihornb -= 25; - ulq -= 25; - - /* Function Body */ - commidi_1.nmidcrd = 0; - commidi_1.notmain = TRUE_; - commidi_1.crdacc = FALSE_; - i__1 = comtrill_1.icrd2; - for (icrd = comtrill_1.icrd1; icrd <= i__1; ++icrd) { - lnote = 0; - nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12); - -/* 3/8/03 save original pitch to use in midi, in case 2nds alter things. */ - - nolevo = nolev; - -/* Check for special situations with 2nds (see precrd). */ - - if (bit_test(*nacc,30)) { - if (nolev == *nolevm - 1) { - nolev = *nolevm; - } - } else if (bit_test(*nacc,31)) { - if (nolev == *nolevm + 1) { - nolev = *nolevm; - } - } - -/* Lower dot for lower-voice notes?. Conditions are: */ -/* 1. Dotted time value */ -/* 2. Lower voice of two */ -/* 3. Note is on a line */ -/* 4. Not a rest (cannot be a rest in a chord!) */ -/* . 5. Flag (lowdot) is set to true */ - - if (comarp_1.lowdot && *nvmx == 2 && *ivx <= *nv) { - i__2 = log2_(nodu); - if (pow_ii(&c__2, &i__2) != *nodu && (nolev - *ncm) % 2 == 0) { - if (bit_test(comtrill_1.icrdat[icrd - 1],26)) { - -/* Note already in movdot list. Drop by 2. */ - - i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, & - c__0) - 20; - setbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__0, & - i__2); - } else { - -/* Not in list so just move it right now */ - - i__2 = igetbits_(islur, &c__1, &c__3); - dotmov_(&c_b735, &c_b736, soutq, lsout, &i__2, (ftnlen)80) - ; - } - } - } - if (bit_test(comtrill_1.icrdat[icrd - 1],26)) { - -/* Move the dot. */ - - updotc = ((127 & comtrill_1.icrdot[icrd - 1]) - 64) * .1f; - rtdotc = ((127 & lbit_shift(comtrill_1.icrdot[icrd - 1], (ftnlen) - -7)) - 64) * .1f; - i__2 = igetbits_(islur, &c__1, &c__3); - dotmov_(&updotc, &rtdotc, soutq, lsout, &i__2, (ftnlen)80); - } - isleft = bit_test(comtrill_1.icrdat[icrd - 1],23); - isright = bit_test(comtrill_1.icrdat[icrd - 1],24); - -/* Check for ornament in chord. */ - - if (comtrill_1.icrdorn[icrd - 1] > 0) { - putorn_(&comtrill_1.icrdorn[icrd - 1], &nolev, nolevm, nodu, & - nornb[1], ulq + 25, ibmcnt, ivx, ncm, islur, nvmx, nv, & - ihornb[25], stemlen, outq, &lout, ip, &c__0, beamon, & - c_true, (ftnlen)1, (ftnlen)79); - -/* subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, */ -/* * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, */ -/* * notcrd,beamon,iscrd) */ - - addstr_(outq, &lout, soutq, lsout, (ftnlen)79, (ftnlen)80); - } - -/* Chord-note symbol. First check for breve */ - - if (*nodu == 128) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "zbreve"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - lsym = 7; - } else { - -/* Not a breve chord. Get first letters in chord-note symbol */ - - if (isleft) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 1, a__1[1] = "l"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } else if (isright) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 1, a__1[1] = "r"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } else { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 1, a__1[1] = "z"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } - if (*nodu >= 64) { -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = nosymq; - i__3[1] = 1, a__1[1] = "w"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } else if (*nodu >= 32) { -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = nosymq; - i__3[1] = 1, a__1[1] = "h"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } else { -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = nosymq; - i__3[1] = 1, a__1[1] = "q"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - } - i__2 = log2_(nodu); - if (pow_ii(&c__2, &i__2) == *nodu && ! (*dotxtup)) { - lsym = 3; - } else if (! bit_test(*islur,3) || *dotxtup) { - -/* Single dot */ - -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = nosymq; - i__3[1] = 1, a__1[1] = "p"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - lsym = 4; - } else { - -/* Double dot */ - -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = nosymq; - i__3[1] = 2, a__1[1] = "pp"; - s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); - lsym = 5; - } - } - if (bit_test(comtrill_1.icrdat[icrd - 1],19) && ! bit_test( - comtrill_1.icrdat[icrd - 1],27)) { - -/* Accidental and not MIDI-only. Build up bits 0-3 of nacc */ - - nactmp = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20); - -/* Kluge for bigness. Only means 'As' has not been issued */ - - if (spfacs_1.bacfac != 1e6f) { - nactmp += 8; - } - i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__20) - - 107; - i__4 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__6, &c__14); - i__5 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12); - i__6 = ncmid_(iv, ip); - L__1 = bit_test(comtrill_1.icrdat[icrd - 1],31); - doacc_(&i__2, &i__4, notexq, &lnote, &nactmp, &i__5, &i__6, &L__1, - (ftnlen)79); -/* * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) */ -/* Get original nolev, not altered to deal with 2nds */ -/* * ncmid(iv,ip)) */ -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 7, a__1[1] = nosymq; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - commidi_1.crdacc = TRUE_; - } else { - s_copy(notexq, nosymq, (ftnlen)79, (ftnlen)7); - } - lnote += lsym; - -/* Get note name (again if accid, due to possible octave jump) */ - - notefq_(noteq, &lnoten, &nolev, ncm, (ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - -/* Put in note name */ - -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 8, a__1[1] = noteq; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote += lnoten; - if (bit_test(comtrill_1.icrdat[icrd - 1],25)) { - -/* Arpeggio signal */ - -/* call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) */ - putarp_(tnow, ivx, ip, &nolev, ncm, soutq, lsout, (ftnlen)80); - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - if (commidi_1.ismidi) { - -/* Here is where we collect MIDI pitch info for the chord note. By checking */ -/* notmain, addmidi(...) knows to just compute the */ -/* pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() */ -/* for MAIN note, will put in note codes for all chord notes + main note. */ - - kv = 1; - if (*ivx > *iv) { - kv = 2; - } - ++commidi_1.nmidcrd; - if (commidi_1.nmidcrd > 20) { - s_wsle(&io___323); - e_wsle(); - s_wsle(&io___324); - do_lio(&c__9, &c__1, "21 chord notes is too many for midi pr" - "ocessor", (ftnlen)45); - e_wsle(); - stop1_(); - } - -/* Use original saved pitch level, unaltered by 2nds logic. */ - -/* call addmidi(midchan(iv,kv),nolevo, */ - i__2 = nolevo - cominsttrans_1.itransamt[cominsttrans_1.instno[* - iv - 1] - 1]; - i__4 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20); - addmidi_(&commidi_1.midchan[*iv + kv * 24 - 25], &i__2, &i__4, & - comtop_1.isig, &c_b781, &c_false, &c_false); - } -/* L5: */ - } - commidi_1.notmain = FALSE_; - return 0; -} /* docrd_ */ - -/* Subroutine */ int dodyn_(integer *ivx, integer *ip, integer *nolev, - integer *ncm, integer *ipl, integer *islur, integer *irest, integer * - nvmx, integer *nv, logical *beamon, integer *ihornb, integer *nornb, - char *ulq, integer *ibmcnt, logical *nostem, char *soutq, integer * - lsout, ftnlen ulq_len, ftnlen soutq_len) -{ - /* Initialized data */ - - static char dyntablq[48] = "ppppppp pp p mp mf f fp sfz ff fff " - "ffff"; - - /* System generated locals */ - address a__1[2], a__2[4], a__3[3], a__4[6]; - integer i__1, i__2, i__3[2], i__4[4], i__5, i__6[3], i__7[6]; - char ch__1[1], ch__2[6], ch__3[81], ch__4[53]; - icilist ici__1; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), - s_copy(char *, char *, ftnlen, ftnlen); - integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) - , s_wsfe(cilist *), e_wsfe(void); - - /* Local variables */ - extern /* Subroutine */ int backfill_(integer *, char *, integer *, char * - , integer *, ftnlen, ftnlen); - static integer jtxtdyn1; - extern integer igetbits_(integer *, integer *, integer *); - static integer lpretweak, id; - static real hoff; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer idno, lbot, idyn, jdyn; - extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *, - integer *, integer *, integer *, integer *); - static integer lbot1; - extern integer lfmt1_(real *); - extern /* Subroutine */ int stop1_(void); - static integer idynd, lform, idynn[10], lnote, ltemp; - static char tempq[48]; - static integer ivxip; - static char numpq[5]; - static integer idynd2; - static real hoffsd; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen); - static integer iptent; - extern integer lenstr_(char *, integer *, ftnlen); - extern /* Subroutine */ int printl_(char *, ftnlen); - static integer numdyn; - static logical upstem; - static char notexq[79]; - static integer lnumpq, icntdyn, ivxtent; - static char dynstrq[4]; - static integer jtxtdyn, ltxtdyn; - - /* Fortran I/O blocks */ - static icilist io___345 = { 0, numpq+1, 0, "(i2)", 2, 1 }; - static icilist io___347 = { 0, numpq+1, 0, "(i2)", 2, 1 }; - static icilist io___348 = { 0, numpq+1, 0, "(i3)", 3, 1 }; - static icilist io___355 = { 0, numpq+1, 0, "(i2)", 2, 1 }; - static icilist io___356 = { 0, numpq+1, 0, "(i2)", 2, 1 }; - static icilist io___357 = { 0, numpq+1, 0, "(i3)", 3, 1 }; - static cilist io___360 = { 0, 11, 0, "(a)", 0 }; - - - -/* Inputs are array *elements* except ihornb,nornb,ulq */ - - /* Parameter adjustments */ - ulq -= 25; - --nornb; - ihornb -= 25; - - /* Function Body */ - numdyn = 0; - -/* Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values */ -/* in idynn(1...4) */ - - i__1 = comdyn_1.ndyn; - for (idyn = 1; idyn <= i__1; ++idyn) { -/* ivxtent = iand(idyndat(idyn),15) */ - ivxtent = (comdyn_1.idyndat[idyn - 1] & 15) + (igetbits_(& - comdyn_1.idynda2[idyn - 1], &c__1, &c__10) << 4); - if (ivxtent == *ivx) { - iptent = igetbits_(&comdyn_1.idyndat[idyn - 1], &c__8, &c__4); - if (iptent == *ip) { - ++numdyn; - idynn[numdyn - 1] = idyn; - } else if (iptent > *ip) { - -/* I don't think there are any more possible for this ivx,ip, so exit loop */ - - goto L2; - } -/* else if (ivxtent .gt. ivx) then */ -/* go to 2 */ - } -/* L1: */ - } -L2: - -/* At this point there is a list of idyn's in idynn(1...numdyn) */ -/* Compute level, and stem-dir'n-based horizontal tweaks */ - - hoffsd = 0.f; - -/* Set upstem to false as default */ - - upstem = FALSE_; - if (bit_test(*irest,0)) { - -/* It's a rest. Assume it doesn't go below the staff */ - - lbot = *ncm - 4; - } else if (! (*beamon)) { - udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, nvmx, ivx, nv); - if (*(unsigned char *)&ch__1[0] == 'u' || *nostem) { - upstem = TRUE_; - if (! bit_test(*ipl,10)) { -/* Computing MIN */ - i__1 = *nolev - 1, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } else { -/* Computing MIN */ - i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } - } else { - hoffsd = -.5f; - if (! bit_test(*ipl,10)) { -/* Computing MIN */ - i__1 = *nolev - 7, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } else { -/* Computing MIN */ - i__1 = comtrill_1.minlev - 7, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } - } - } else { - if (*(unsigned char *)&ulq[*ivx + *ibmcnt * 24] == 'u') { - upstem = TRUE_; - if (! bit_test(*ipl,10)) { -/* Computing MIN */ - i__1 = *nolev - 1, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } else { -/* Computing MIN */ - i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4; - lbot = min(i__1,i__2); - } - } else { - hoffsd = -.5f; - lbot = ihornb[*ivx + nornb[*ivx] * 24] + 1; - if (lbot == 1) { - -/* Kluge for non-beamed, down xtup, for which ihorb was never set. */ -/* Assumes stem is shortened. */ - - lbot = *nolev - 5; - } - ++nornb[*ivx]; - } - } - lbot += -5; - jtxtdyn1 = 1; - -/* Now ready to loop over current dyn's */ - - i__1 = numdyn; - for (icntdyn = 1; icntdyn <= i__1; ++icntdyn) { - idynd = comdyn_1.idyndat[idynn[icntdyn - 1] - 1]; - idynd2 = comdyn_1.idynda2[idynn[icntdyn - 1] - 1]; - idno = igetbits_(&idynd, &c__4, &c__12); -/* ivx = iand(15,idynd) */ - *ivx = (15 & idynd) + (igetbits_(&idynd2, &c__1, &c__10) << 4); - -/* Build the command into notex in stages. Insert name & rq'd args in order: */ - -/* Command name */ -/* hpstrt, hpcend, hpdend, pmxdyn */ -/* ivx */ -/* X X X */ -/* level */ -/* X X X */ -/* hoff */ -/* X X X X */ -/* d-mark */ -/* X */ - - if (idno == 0) { - -/* Text-dynamic */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "txtdyn"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote = 7; - } else if (idno <= 12) { - -/* Letter-group */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "pmxdyn"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote = 7; - } else if (comslur_1.fontslur) { - lnote = 7; - if (idno == 13) { - -/* Start a hairpin */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "hpstrt"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - } else if (idno == 14) { - -/* End crescendo */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "hpcend"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - } else { - -/* End decrescendo */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "hpdend"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - } - } else { - -/* Postscript hairpins */ - - lnote = 7; - if (idno == 13) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "Icresc"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - } else if (idno == 14) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 8, a__1[1] = "Idecresc"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote = 9; - } else { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "Tcresc"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - } - } - if (idno >= 13) { - -/* Put in voice number */ - - if (*ivx <= 9) { -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - *(unsigned char *)&ch__1[0] = *ivx + 48; - i__3[1] = 1, a__1[1] = ch__1; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - ++lnote; - } else if (*ivx <= 19) { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{1"; - *(unsigned char *)&ch__1[0] = *ivx + 38; - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{2"; - *(unsigned char *)&ch__1[0] = *ivx + 28; - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } - } - -/* Begin setting level */ - - lbot1 = lbot; - if (idno > 0 && idno <= 5) { - -/* All letters are short so raise a bit. */ - - ++lbot1; - } else if (idno >= 13) { - lbot1 += 2; - } - -/* Convert so reference is bottom line */ - - lbot1 = lbot1 - *ncm + 4; - if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno - == 13 || idno == 14)) { - -/* Hairpin start. Save level and user-tweak before applying user tweak. */ - - comdyn_1.levdsav[*ivx - 1] = lbot1; - comdyn_1.levhssav[*ivx - 1] = 0; - if (bit_test(idynd,16)) { - comdyn_1.levhssav[*ivx - 1] = igetbits_(&idynd, &c__7, &c__17) - - 64; - } - } else if (comslur_1.fontslur && idno >= 14 || idno == 15) { - -/* Hairpin end; Compare level with saved start level before user-tweaks */ - -/* Computing MIN */ - i__2 = lbot1, i__5 = comdyn_1.levdsav[*ivx - 1]; - lbot1 = min(i__2,i__5); - -/* Save pre-tweak level */ - - lpretweak = lbot1; - } - -/* Check for user-defined vertical tweak */ - - if (bit_test(idynd,16)) { - lbot1 = lbot1 - 64 + igetbits_(&idynd, &c__7, &c__17); - } - -/* Now horizontal stuff */ - - hoff = hoffsd; - -/* Some special horizontal tweaks */ - - if (upstem && idno > 0 && (idno <= 4 || idno == 8 || idno == 9)) { - hoff += .4f; - } - -/* User-defined tweaks */ - - if (bit_test(idynd2,0)) { - hoff += (igetbits_(&idynd2, &c__9, &c__1) - 256) * .1f; - } - if (numdyn > 1) { - -/* Horizontal-interaction-based tweaks. */ - -/* Cases: */ -/* numdyn type1 type2 type3 data used */ -/* 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) */ -/* 2 hrpnend wrd-grp - ivowg,hoh2 */ -/* 2 hrpnend hrpnstrt - hoh2h1(1...2) */ -/* 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 */ - - if (idno > 0 && idno <= 12) { - -/* Word-group, may need vertical tweak to line up. */ - - lbot1 += comdyn_1.ivowg[idno - 1]; - -/* Protecting against hp start-stop on same note */ - - } else if ((comslur_1.fontslur && idno >= 14 || idno == 15) && - icntdyn < numdyn) { - -/* Hairpin ending, check next type */ - - if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[ - icntdyn] - 1], &c__4, &c__12) == 13 || ! - comslur_1.fontslur && (igetbits_(&comdyn_1.idyndat[ - idynn[icntdyn] - 1], &c__4, &c__12) == 13 || - igetbits_(&comdyn_1.idyndat[idynn[icntdyn] - 1], & - c__4, &c__12) == 14)) { - -/* Hairpin end then hairpin start, no words, (remember dealing with end now) */ - - hoff += comdyn_1.hoh2h1[0]; - } else { - -/* Hairpin end then word-group, need idno for w-g to set hp offset */ - - hoff += comdyn_1.hoh2[igetbits_(&comdyn_1.idyndat[idynn[ - icntdyn] - 1], &c__4, &c__12) - 1]; - } - -/* Protecting against hp start-stop on same note */ - - } else if (icntdyn > 1 && idno > 0 && (comslur_1.fontslur && idno - < 14 || ! comslur_1.fontslur && idno < 15)) { - -/* Hairpin start, check prior type */ - - if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[ - icntdyn - 2] - 1], &c__4, &c__12) >= 14 || ! - comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[ - idynn[icntdyn - 2] - 1], &c__4, &c__12) == 15) { - -/* Hairpin end then hairpin start, (remember dealing with start now) */ - - hoff += comdyn_1.hoh2h1[1]; - } else { - -/* Hairpin start after word-group, need idno for w-g to set hp offset */ - - hoff += comdyn_1.hoh1[igetbits_(&comdyn_1.idyndat[idynn[ - icntdyn - 2] - 1], &c__4, &c__12) - 1]; - } - } - } - -/* End of if-block for 2- or 3-way interactions. */ - - if (! comslur_1.fontslur && idno >= 13) { - hoff = (hoff + .5f) * 6.f / 2.5f; - } - -/* Slur font and hairpin. Add hoff, and change from \interneote to \qn@width */ - - -/* Position corrections all done now. Put in the level. */ - - if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno - == 13 || idno == 14)) { - -/* Hairpin start. */ - - if (! comslur_1.fontslur) { - -/* Postscript hairpin start...inset placeholder for start level. */ -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 5, a__1[1] = "{ }"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote += 5; - } - } else { - -/* Insert actual level in all cases except hairpin start */ -/* Create string with level in it */ - - if (lbot1 > 9) { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___345); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 4; - } else if (lbot1 > -1) { - *(unsigned char *)&ch__1[0] = lbot1 + 48; - s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1); - lnumpq = 1; - } else if (lbot1 > -10) { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___347); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 4; - } else { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___348); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 4, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 5; - } - -/* Level has now been computed and stored in numpq */ -/* Append the level */ - -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = lnumpq, a__1[1] = numpq; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - lnote += lnumpq; - } - if (dabs(hoff) < .001f) { - -/* No horiz offset */ - -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 1, a__1[1] = "0"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - ++lnote; - } else { - -/* Horizontal tweak */ - - lform = lfmt1_(&hoff); -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 1, a__1[1] = "{"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - ++lnote; - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + lform - i__2; - ici__1.iciunit = notexq + i__2; -/* Writing concatenation */ - i__6[0] = 2, a__3[0] = "(f"; - i__5 = lform + 48; - chax_(ch__1, (ftnlen)1, &i__5); - i__6[1] = 1, a__3[1] = ch__1; - i__6[2] = 3, a__3[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__2, a__3, i__6, &c__3, (ftnlen)6), - ch__2); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&hoff, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += lform; -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); - ++lnote; - } - if (idno == 0) { - -/* text-dynamic. Find the string and append it */ - - i__2 = comdyn_1.ntxtdyn; - for (jtxtdyn = jtxtdyn1; jtxtdyn <= i__2; ++jtxtdyn) { -/* ivxip = ivx+16*ip */ - ivxip = *ivx + (*ip << 5); - if (ivxip == comdyn_1.ivxiptxt[jtxtdyn - 1]) { - goto L5; - } -/* L4: */ - } - printl_("Abnormal stop in putdyn", (ftnlen)23); - stop1_(); -L5: - ltxtdyn = lenstr_(comdyn_1.txtdynq + (jtxtdyn - 1 << 7), &c__128, - (ftnlen)128); - -/* Font size based on musicsize */ - - if (commus_1.musize == 20) { -/* Writing concatenation */ - i__7[0] = lnote, a__4[0] = notexq; - i__7[1] = 1, a__4[1] = "{"; - i__7[2] = 1, a__4[2] = "\\"; - i__7[3] = 7, a__4[3] = "medtype"; - i__7[4] = 1, a__4[4] = "\\"; - i__7[5] = 3, a__4[5] = "it "; - s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); - lnote += 13; - } else if (commus_1.musize == 16) { -/* Writing concatenation */ - i__7[0] = lnote, a__4[0] = notexq; - i__7[1] = 1, a__4[1] = "{"; - i__7[2] = 1, a__4[2] = "\\"; - i__7[3] = 8, a__4[3] = "normtype"; - i__7[4] = 1, a__4[4] = "\\"; - i__7[5] = 3, a__4[5] = "it "; - s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); - lnote += 14; - } else if (commus_1.musize == 24) { -/* Writing concatenation */ - i__7[0] = lnote, a__4[0] = notexq; - i__7[1] = 1, a__4[1] = "{"; - i__7[2] = 1, a__4[2] = "\\"; - i__7[3] = 7, a__4[3] = "bigtype"; - i__7[4] = 1, a__4[4] = "\\"; - i__7[5] = 3, a__4[5] = "it "; - s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); - lnote += 13; - } else if (commus_1.musize == 29) { -/* Writing concatenation */ - i__7[0] = lnote, a__4[0] = notexq; - i__7[1] = 1, a__4[1] = "{"; - i__7[2] = 1, a__4[2] = "\\"; - i__7[3] = 7, a__4[3] = "Bigtype"; - i__7[4] = 1, a__4[4] = "\\"; - i__7[5] = 3, a__4[5] = "it "; - s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); - lnote += 13; - } -/* Writing concatenation */ - i__6[0] = lnote, a__3[0] = notexq; - i__6[1] = ltxtdyn, a__3[1] = comdyn_1.txtdynq + (jtxtdyn - 1 << 7) - ; - i__6[2] = 1, a__3[2] = "}"; - s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79); - lnote = lnote + ltxtdyn + 1; - -/* Reset jtxtdyn1 just in case >1 txtdyn on same note. */ - - jtxtdyn1 = jtxtdyn + 1; - } else if (idno <= 12) { - -/* Letter-group dynamic. Append the letter-group command */ - - id = idno << 2; - i__2 = id - 4; - s_copy(dynstrq, dyntablq + i__2, (ftnlen)4, id - i__2); - id = lenstr_(dynstrq, &c__4, (ftnlen)4); -/* Writing concatenation */ - i__6[0] = lnote, a__3[0] = notexq; - chax_(ch__1, (ftnlen)1, &c__92); - i__6[1] = 1, a__3[1] = ch__1; - i__6[2] = id, a__3[2] = dynstrq; - s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79); - lnote = lnote + 1 + id; - } - addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80); - if (! comslur_1.fontslur && idno == 15) { - -/* PS slurs on, hairpin is ending. Go back and set height at beginning. */ -/* Add user-defined tweak to default level */ - - lbot1 = lpretweak + comdyn_1.levhssav[*ivx - 1]; - if (lbot1 > 9) { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___355); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 4; - } else if (lbot1 > -1) { - *(unsigned char *)&ch__1[0] = lbot1 + 48; - s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1); - lnumpq = 1; - } else if (lbot1 > -10) { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___356); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 3, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 4; - } else { - s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); - s_wsfi(&io___357); - do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 4, a__1[0] = numpq; - i__3[1] = 1, a__1[1] = "}"; - s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); - lnumpq = 5; - } - -/* Construct string to search backwards for placeholder */ - - if (*ivx <= 9) { -/* Writing concatenation */ - i__6[0] = 5, a__3[0] = "cresc"; - *(unsigned char *)&ch__1[0] = *ivx + 48; - i__6[1] = 1, a__3[1] = ch__1; - i__6[2] = 5, a__3[2] = "{ }"; - s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); - ltemp = 11; - } else if (*ivx <= 19) { -/* Writing concatenation */ - i__6[0] = 7, a__3[0] = "cresc{1"; - *(unsigned char *)&ch__1[0] = *ivx + 38; - i__6[1] = 1, a__3[1] = ch__1; - i__6[2] = 6, a__3[2] = "}{ }"; - s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); - ltemp = 14; - } else { -/* Writing concatenation */ - i__6[0] = 7, a__3[0] = "cresc{2"; - *(unsigned char *)&ch__1[0] = *ivx + 28; - i__6[1] = 1, a__3[1] = ch__1; - i__6[2] = 6, a__3[2] = "}{ }"; - s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); - ltemp = 14; - } - s_wsfe(&io___360); -/* Writing concatenation */ - i__3[0] = *lsout, a__1[0] = soutq; - i__3[1] = 1, a__1[1] = "%"; - s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)81); - do_fio(&c__1, ch__3, *lsout + 1); - e_wsfe(); - *lsout = 0; -/* Writing concatenation */ - i__3[0] = ltemp - 5, a__1[0] = tempq; - i__3[1] = lnumpq, a__1[1] = numpq; - s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)53); - i__2 = ltemp - 5 + lnumpq; - backfill_(&c__11, tempq, <emp, ch__4, &i__2, (ftnlen)48, ltemp - - 5 + lnumpq); - } -/* L3: */ - } - -/* Shrink arrays, decrease ndyn 111109 */ - - for (icntdyn = numdyn; icntdyn >= 1; --icntdyn) { - i__1 = comdyn_1.ndyn - 1; - for (jdyn = idynn[icntdyn - 1]; jdyn <= i__1; ++jdyn) { - comdyn_1.idyndat[jdyn - 1] = comdyn_1.idyndat[jdyn]; - comdyn_1.idynda2[jdyn - 1] = comdyn_1.idynda2[jdyn]; -/* L7: */ - } - --comdyn_1.ndyn; -/* L6: */ - } - return 0; -} /* dodyn_ */ - -/* Subroutine */ int dograce_(integer *ivx, integer *ip, real *ptgr, char * - soutq, integer *lsout, integer *ncm, integer *nacc, integer *ig, - integer *ipl, logical *farend, logical *beamon, integer *nolev, - integer *ncmidx, integer *islur, integer *nvmx, integer *nv, integer * - ibmcnt, real *tnote, char *ulq, ftnlen soutq_len, ftnlen ulq_len) -{ - /* System generated locals */ - address a__1[2], a__2[3], a__3[4]; - integer i__1, i__2[2], i__3[3], i__4[4], i__5, i__6; - real r__1; - char ch__1[1], ch__2[6], ch__3[2], ch__4[5], ch__5[11], ch__6[7], ch__7[4] - , ch__8[87], ch__9[15], ch__10[16], ch__11[9], ch__12[12], ch__13[ - 21], ch__14[20], ch__15[19], ch__16[24], ch__17[13], ch__18[82], - ch__19[3], ch__20[10]; - icilist ici__1; - - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - /* Subroutine */ int s_stop(char *, ftnlen); - integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer i_nint(real *), s_wsfi(icilist *), e_wsfi(void); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer i_sign(integer *, integer *); - - /* Local variables */ - extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); - static integer lnotenga; - extern integer igetbits_(integer *, integer *, integer *); - static integer i__; - static real x, y, em; - static integer mg; - static char sq[1]; - static real finalshift; - static integer ing, ngs; - extern integer log2_(integer *); - static integer lacc; - static real beta; - extern /* Character */ VOID chax_(char *, ftnlen, integer *), udqq_(char * - , ftnlen, integer *, integer *, integer *, integer *, integer *, - integer *); - static real sumx, sumy; - extern /* Subroutine */ int stop1_(void); - static real delta, ptoff; - static integer lnote; - static char noteq[8]; - static real sumxx, sumxy, sumyy; - static integer nolev1; - static logical isgaft; - extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen), - addstr_(char *, integer *, char *, integer *, ftnlen, ftnlen); - static integer islope; - static logical iswaft; - static char acsymq[3]; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static integer lnoten, itrans, niptgr; - static logical stemup, normsp; - static char notexq[79], noteqga[8]; - static real wheadpt1; - - /* Fortran I/O blocks */ - static cilist io___366 = { 0, 6, 0, 0, 0 }; - static cilist io___370 = { 0, 6, 0, 0, 0 }; - static cilist io___371 = { 0, 6, 0, 0, 0 }; - static cilist io___372 = { 0, 15, 0, "(/,a)", 0 }; - static icilist io___375 = { 0, notexq, 0, "(i2)", 2, 1 }; - static cilist io___376 = { 0, 6, 0, 0, 0 }; - static icilist io___400 = { 0, notexq+13, 0, "(a1,f4.1)", 5, 1 }; - static icilist io___402 = { 0, notexq+13, 0, "(f4.1)", 4, 1 }; - static icilist io___404 = { 0, notexq+5, 0, "(f3.1)", 3, 1 }; - - - -/* ip will be one LESS than current note, for way-after's before bar-end, */ -/* It is only used to find ig. */ -/* ig is returned to makeabar in case there's a slur that needs to be ended */ - - /* Parameter adjustments */ - ulq -= 25; - --ptgr; - - /* Function Body */ - chax_(ch__1, (ftnlen)1, &c__92); - *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; - isgaft = bit_test(*ipl,29); - iswaft = bit_test(*ipl,31); - normsp = ! isgaft; - -/* Find ig. */ - - i__1 = comgrace_1.ngrace; - for (*ig = 1; *ig <= i__1; ++(*ig)) { - if (comgrace_1.ipg[*ig - 1] == *ip && comgrace_1.ivg[*ig - 1] == *ivx) - { - goto L121; - } -/* L120: */ - } - s_wsle(&io___366); - do_lio(&c__9, &c__1, "Problem finding grace index in dograce", (ftnlen)38) - ; - e_wsle(); - s_stop("", (ftnlen)0); -L121: - ngs = comgrace_1.ngstrt[*ig - 1]; - mg = comgrace_1.multg[*ig - 1]; - wheadpt1 = comask_1.wheadpt * comfig_1.fullsize[*ivx - 1]; - -/* For way-after-graces at end of bar, must set the octave. */ - - if (*farend) { - comoct_1.noctup = 0; - if (*ncm == 23) { - comoct_1.noctup = -2; - } - } - if (comgrace_1.slurg[*ig - 1] && ! iswaft && ! isgaft) { - if (comslur_1.listslur == 16777215) { - s_wsle(&io___370); - e_wsle(); - s_wsle(&io___371); - do_lio(&c__9, &c__1, "You defined the twentyfifth slur, one too " - "many!", (ftnlen)47); - e_wsle(); - s_wsfe(&io___372); - do_fio(&c__1, "You defined the twentyfifth slur, one too many!", ( - ftnlen)47); - e_wsfe(); - stop1_(); - } - -/* Slur on fore-grace. Get index of next slur not in use, from 23 down. */ - - i__1 = 16777215 - comslur_1.listslur; - comslur_1.ndxslur = log2_(&i__1); - } - if (comgrace_1.nng[*ig - 1] == 1) { - -/* Single grace. */ - - if (normsp) { - -/* Anything but GA */ - -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 5, a__1[1] = "shlft"; - s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); - addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80); - niptgr = i_nint(&ptgr[*ig]); - -/* Empirical tweak for postscript. */ - -/* if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) */ -/* ++ */ - if (niptgr < 10) { -/* Writing concatenation */ - i__1 = niptgr + 48; - chax_(ch__1, (ftnlen)1, &i__1); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = 1, a__1[1] = "{"; - s_cat(ch__3, a__1, i__2, &c__2, (ftnlen)2); - addstr_(ch__3, &c__2, soutq, lsout, (ftnlen)2, (ftnlen)80); - } else if (niptgr < 100) { - s_wsfi(&io___375); - do_fio(&c__1, (char *)&niptgr, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = "{"; - i__3[1] = 2, a__2[1] = notexq; - i__3[2] = 2, a__2[2] = "}{"; - s_cat(ch__4, a__2, i__3, &c__3, (ftnlen)5); - addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80); - } else { - s_wsle(&io___376); - do_lio(&c__9, &c__1, "Call Dr. Don if you really want grace " - "note group > 99 pt", (ftnlen)56); - e_wsle(); - s_stop("", (ftnlen)0); - } - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 10, a__1[1] = "gaft{1.5}{"; - s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11); - addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80); - -/* GA. Compute aftshft, for later use. */ - - comgrace_1.aftshft = spfacs_1.grafac; - if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) { - comgrace_1.aftshft += spfacs_1.agc1fac; - } - comgrace_1.aftshft *= comask_1.wheadpt; - } - if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) { - -/* Start slur on pre-grace. No accounting needed since will be ended very soon. */ - - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) - 8); - if (comslur_1.fontslur) { - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 6, a__1[1] = "islurd"; - s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); - addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) - ; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 6, a__1[1] = "isluru"; - s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); - addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) - ; - } - } else { - -/* Start Postscript slur. */ - - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 3, a__1[1] = "isd"; - s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); - addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) - ; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 3, a__1[1] = "isu"; - s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); - addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) - ; - } - } - -/* Print slur number, 23-ndxslur */ - - lnote = 0; - if (23 - comslur_1.ndxslur < 10) { -/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ - i__1 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1); - lnote = 1; - } else if (23 - comslur_1.ndxslur < 20) { -/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ -/* Writing concatenation */ - i__3[0] = 2, a__2[0] = "{1"; - i__1 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__3[1] = 1, a__2[1] = ch__1; - i__3[2] = 1, a__2[2] = "}"; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - lnote = 4; - } else { -/* Writing concatenation */ - i__4[0] = lnote, a__3[0] = notexq; - i__4[1] = 2, a__3[1] = "{2"; - i__1 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__4[2] = 1, a__3[2] = ch__1; - i__4[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); - lnote = 4; - } -/* if (11-ndxslur .lt. 10) then */ -/* call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, */ -/* * soutq,lsout) */ -/* else */ -/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */ -/* * 4+lnoten,soutq,lsout) */ -/* end if */ -/* Writing concatenation */ - i__2[0] = lnote, a__1[0] = notexq; - i__2[1] = lnoten, a__1[1] = noteq; - s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87); - i__1 = lnote + lnoten; - addstr_(ch__8, &i__1, soutq, lsout, lnote + lnoten, (ftnlen)80); - if (! comslur_1.fontslur) { - -/* Horizontal tweaks for postscript slur on single grace */ - - stemup = TRUE_; - if (comgrace_1.upg[*ig - 1]) { - -/* Check for up-grace + down stem. Get stem direction */ - - if (! (*beamon)) { - -/* Separate note. Get stem direction. */ - - udqq_(ch__1, (ftnlen)1, nolev, ncmidx, islur, nvmx, - ivx, nv); - stemup = *(unsigned char *)&ch__1[0] == 'u'; - } else { - -/* In a beam */ - - stemup = *(unsigned char *)&ulq[*ivx + *ibmcnt * 24] - == 'u'; - } - -/* Stop the shift if whole note */ - - stemup = stemup || *tnote > 63.f; - } - if (stemup) { - addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen) - 80); - } else { - addstr_("{-.8}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen) - 80); - } - } - } - if (comgrace_1.naccg[ngs - 1] > 0) { - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) - 8); - -/* Save for checking octave shifts in GA */ - - if (isgaft) { - lnotenga = lnoten; - s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8); - } - - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3); -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 3, a__3[1] = "big"; - i__4[2] = lacc, a__3[2] = acsymq; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15); - i__1 = lacc + 4 + lnoten; - addstr_(ch__9, &i__1, soutq, lsout, lacc + 4 + lnoten, (ftnlen)80) - ; - } - if (comgrace_1.slashg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 3, a__1[1] = "grc"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - lnote = 4; - } else if (mg == 0) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 2, a__1[1] = "zq"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - lnote = 3; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 2, a__1[1] = "zc"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - i__1 = mg; - for (i__ = 2; i__ <= i__1; ++i__) { -/* Writing concatenation */ - i__2[0] = i__ + 1, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "c"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); -/* L61: */ - } - lnote = mg + 2; - } - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "u"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__2[0] = lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "l"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - } - i__1 = lnote + 1; - addstr_(notexq, &i__1, soutq, lsout, (ftnlen)79, (ftnlen)80); - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8); - - if (isgaft && comgrace_1.naccg[ngs - 1] == 0) { - lnotenga = lnoten; - s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8); - } - - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - addstr_(noteq, &lnoten, soutq, lsout, (ftnlen)8, (ftnlen)80); - if (comgrace_1.slashg[*ig - 1]) { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 5, a__3[1] = "off{-"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 9, a__3[3] = "noteskip}"; - s_cat(ch__10, a__3, i__4, &c__4, (ftnlen)16); - addstr_(ch__10, &c__16, soutq, lsout, (ftnlen)16, (ftnlen)80); - } - -/* Above code needed since slashg causes spacing */ - - if (comgrace_1.slurg[*ig - 1] && (iswaft || isgaft)) { - -/* Terminate slur on single after-grace */ - -/* ndxslur = igetbits(ipl,4,23) */ - comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23); - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) - 8); -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 5, a__1[1] = "tslur"; - s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); - addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80); - -/* c Print 11-ndxslur */ -/* Print 24-ndxslur */ - -/* if (11-ndxslur .lt. 10) then */ - if (23 - comslur_1.ndxslur < 10) { -/* call addstr(chax(59-ndxslur)//noteq(1:lnoten), */ -/* Writing concatenation */ - i__1 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = lnoten, a__1[1] = noteq; - s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); - i__5 = lnoten + 1; - addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80); - } else if (23 - comslur_1.ndxslur < 20) { -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{2"; - i__1 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__5 = lnoten + 4; - addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); - } else { -/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */ -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{1"; - i__1 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__5 = lnoten + 4; - addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); - } - comgrace_1.slurg[*ig - 1] = FALSE_; - comslur_1.listslur = bit_clear(comslur_1.listslur, - comslur_1.ndxslur); - } - addstr_("}", &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80); - -/* +++ Try to fix loss of octave with single gaft */ - -/* if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', */ -/* * 13+lnoten,soutq,lsout) */ - if (isgaft) { - itrans = 0; - i__1 = lnotenga; - for (i__ = 1; i__ <= i__1; ++i__) { - chax_(ch__1, (ftnlen)1, &c__39); - if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned char *)& - ch__1[0]) { - itrans += 7; - } else /* if(complicated condition) */ { - chax_(ch__1, (ftnlen)1, &c__96); - if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned - char *)&ch__1[0]) { - itrans += -7; - } - } -/* L1: */ - } - if (itrans == -14) { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 7, a__3[1] = "advance"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 12, a__3[3] = "transpose-14"; - s_cat(ch__13, a__3, i__4, &c__4, (ftnlen)21); - addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80); - } else if (itrans == -7) { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 7, a__3[1] = "advance"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 11, a__3[3] = "transpose-7"; - s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20); - addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80); - } else if (itrans == 7) { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 7, a__3[1] = "advance"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 10, a__3[3] = "transpose7"; - s_cat(ch__15, a__3, i__4, &c__4, (ftnlen)19); - addstr_(ch__15, &c__19, soutq, lsout, (ftnlen)19, (ftnlen)80); - } else if (itrans == 14) { -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 7, a__3[1] = "advance"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 11, a__3[3] = "transpose14"; - s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20); - addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80); - } - } - } else { - -/* Multiple grace. Put in literally. Compute beam stuff */ - - sumx = 0.f; - sumy = 0.f; - sumxy = 0.f; - sumxx = 0.f; - sumyy = 0.f; - x = 0.f; - i__1 = ngs + comgrace_1.nng[*ig - 1] - 1; - for (ing = ngs; ing <= i__1; ++ing) { - if (ing > ngs && comgrace_1.naccg[ing - 1] > 0) { - x += spfacs_1.acgfac; - } - y = (real) comgrace_1.nolevg[ing - 1]; - sumx += x; - sumy += y; - sumxy += x * y; - sumxx += x * x; - sumyy += y * y; - x += spfacs_1.emgfac; -/* L118: */ - } - delta = comgrace_1.nng[*ig - 1] * sumxx - sumx * sumx; - em = (comgrace_1.nng[*ig - 1] * sumxy - sumx * sumy) / delta; - r__1 = em * .5f * spfacs_1.gslfac; - islope = i_nint(&r__1); - if (abs(islope) > 9) { - islope = i_sign(&c__9, &islope); - } - beta = (sumy - islope / spfacs_1.gslfac * sumx) / comgrace_1.nng[*ig - - 1]; - nolev1 = i_nint(&beta); - -/* Back up */ - -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 7, a__3[1] = "settiny"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 4, a__3[3] = "off{"; - s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); - if (normsp) { - s_wsfi(&io___400); - do_fio(&c__1, "-", (ftnlen)1); - do_fio(&c__1, (char *)&ptgr[*ig], (ftnlen)sizeof(real)); - e_wsfi(); -/* Writing concatenation */ - i__2[0] = 18, a__1[0] = notexq; - i__2[1] = 3, a__1[1] = "pt}"; - s_cat(ch__13, a__1, i__2, &c__2, (ftnlen)21); - addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80); - finalshift = ptgr[*ig]; - } else { - comgrace_1.aftshft = comask_1.wheadpt * 1.33f; - if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) { - comgrace_1.aftshft += comask_1.wheadpt * .5f; - } - s_wsfi(&io___402); - do_fio(&c__1, (char *)&comgrace_1.aftshft, (ftnlen)sizeof(real)); - e_wsfi(); -/* Writing concatenation */ - i__4[0] = 17, a__3[0] = notexq; - i__4[1] = 3, a__3[1] = "pt}"; - i__4[2] = 1, a__3[2] = sq; - i__4[3] = 3, a__3[3] = "bsk"; - s_cat(ch__16, a__3, i__4, &c__4, (ftnlen)24); - addstr_(ch__16, &c__24, soutq, lsout, (ftnlen)24, (ftnlen)80); - } - -/* Start the beam */ - -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 2, a__1[1] = "ib"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - i__1 = mg; - for (ing = 2; ing <= i__1; ++ing) { -/* Writing concatenation */ - i__2[0] = ing + 1, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "b"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); -/* L119: */ - } - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = mg + 2, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "u"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__2[0] = mg + 2, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "l"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - } -/* Writing concatenation */ - i__2[0] = mg + 3, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "0"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - -/* Get starting note for beam */ - - notefq_(noteq, &lnoten, &nolev1, ncm, (ftnlen)8); -/* Writing concatenation */ - i__2[0] = mg + 4, a__1[0] = notexq; - i__2[1] = lnoten, a__1[1] = noteq; - s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87); - i__1 = mg + 4 + lnoten; - addstr_(ch__8, &i__1, soutq, lsout, mg + 4 + lnoten, (ftnlen)80); - -/* Put in the slope */ - - if (islope >= 0) { - i__1 = islope + 48; - chax_(ch__1, (ftnlen)1, &i__1); - addstr_(ch__1, &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80); - } else { -/* Writing concatenation */ - i__3[0] = 2, a__2[0] = "{-"; - i__1 = 48 - islope; - chax_(ch__1, (ftnlen)1, &i__1); - i__3[1] = 1, a__2[1] = ch__1; - i__3[2] = 1, a__2[2] = "}"; - s_cat(ch__7, a__2, i__3, &c__3, (ftnlen)4); - addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80); - } - -/* Start a slur on multiple fore-grace */ - - if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) { - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) - 8); - if (comslur_1.fontslur) { - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 6, a__1[1] = "islurd"; - s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); - addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) - ; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 6, a__1[1] = "isluru"; - s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); - addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) - ; - } - } else { - -/* Need a tweak for postscript slur */ - - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 3, a__1[1] = "isd"; - s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); - addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) - ; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 3, a__1[1] = "isu"; - s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); - addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) - ; - } - } - -/* Print 11-ndxslur */ - - if (23 - comslur_1.ndxslur < 10) { -/* Writing concatenation */ - i__1 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = lnoten, a__1[1] = noteq; - s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); - i__5 = lnoten + 1; - addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80); - } else if (23 - comslur_1.ndxslur < 2) { -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{1"; - i__1 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__5 = lnoten + 4; - addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); - } else { -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{1"; - i__1 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__1); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__5 = lnoten + 4; - addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); - } - -/* Put in tweak for postscript slur */ - - if (! comslur_1.fontslur) { - addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80); - } - } - -/* Put in first note. Call notefq again in case octave changed */ - - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8); - if (comgrace_1.naccg[ngs - 1] == 0) { -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = sq; - i__3[1] = 4, a__2[1] = "zqb0"; - i__3[2] = lnoten, a__2[2] = noteq; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - lnote = lnoten + 5; - } else { - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3); -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 3, a__3[1] = "big"; - i__4[2] = lacc, a__3[2] = acsymq; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); - lnote = lacc + 4 + lnoten; - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) - 8); -/* Writing concatenation */ - i__4[0] = lnote, a__3[0] = notexq; - i__4[1] = 1, a__3[1] = sq; - i__4[2] = 4, a__3[2] = "zqb0"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); - lnote = lnote + 5 + lnoten; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - i__1 = ngs + comgrace_1.nng[*ig - 1] - 1; - for (ing = ngs + 1; ing <= i__1; ++ing) { - -/* Skip */ - - ptoff = wheadpt1 * spfacs_1.emgfac; - if (comgrace_1.naccg[ing - 1] > 0) { - ptoff += wheadpt1 * spfacs_1.acgfac; - } - if (isgaft && ! iswaft) { - comgrace_1.aftshft += ptoff; - } -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 4, a__1[1] = "off{"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - s_wsfi(&io___404); - do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); - e_wsfi(); - if (normsp) { - finalshift -= ptoff; - } -/* Writing concatenation */ - i__2[0] = 8, a__1[0] = notexq; - i__2[1] = 3, a__1[1] = "pt}"; - s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11); - addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80); - if (ing == ngs + comgrace_1.nng[*ig - 1] - 1) { - -/* Terminate beam if needed */ - - if (comgrace_1.upg[*ig - 1]) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 4, a__1[1] = "tbu0"; - s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5); - addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80) - ; - } else { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 4, a__1[1] = "tbl0"; - s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5); - addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80) - ; - } - -/* Terminate after slur if needed */ - - if ((isgaft || iswaft) && comgrace_1.slurg[*ig - 1]) { -/* if (iswaft) ndxslur = igetbits(ipl,4,23) */ - if (iswaft) { - comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23); - } - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, - (ftnlen)8); -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 5, a__1[1] = "tslur"; - s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); - addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80) - ; - -/* Print 11-ndxslur */ -/* c Print 23-ndxslur */ - - if (23 - comslur_1.ndxslur < 10) { -/* Writing concatenation */ - i__5 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__5); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = lnoten, a__1[1] = noteq; - s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); - i__6 = lnoten + 1; - addstr_(ch__11, &i__6, soutq, lsout, lnoten + 1, ( - ftnlen)80); - } else if (23 - comslur_1.ndxslur < 20) { -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{2"; - i__5 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__5); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__6 = lnoten + 4; - addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, ( - ftnlen)80); - } else { -/* Writing concatenation */ - i__4[0] = 2, a__3[0] = "{1"; - i__5 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__5); - i__4[1] = 1, a__3[1] = ch__1; - i__4[2] = 1, a__3[2] = "}"; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); - i__6 = lnoten + 4; - addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, ( - ftnlen)80); - } - -/* Stop slur terminator after exit from this subroutine */ - - comslur_1.listslur = bit_clear(comslur_1.listslur, - comslur_1.ndxslur); - comgrace_1.slurg[*ig - 1] = FALSE_; - } - } - -/* Accidental if needed */ - - if (comgrace_1.naccg[ing - 1] > 0) { - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, ( - ftnlen)8); - if (lnoten == 1) { - addblank_(noteq, &lnoten, (ftnlen)8); - } - accsym_(&comgrace_1.naccg[ing - 1], acsymq, &lacc, (ftnlen)3); -/* Writing concatenation */ - i__4[0] = 1, a__3[0] = sq; - i__4[1] = 3, a__3[1] = "big"; - i__4[2] = lacc, a__3[2] = acsymq; - i__4[3] = lnoten, a__3[3] = noteq; - s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15); - i__5 = lacc + 4 + lnoten; - addstr_(ch__9, &i__5, soutq, lsout, lacc + 4 + lnoten, ( - ftnlen)80); - } - -/* Put in the (beamed) grace note */ - - notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, (ftnlen) - 8); -/* Writing concatenation */ - i__3[0] = 1, a__2[0] = sq; - i__3[1] = 4, a__2[1] = "zqb0"; - i__3[2] = lnoten, a__2[2] = noteq; - s_cat(ch__17, a__2, i__3, &c__3, (ftnlen)13); - i__5 = lnoten + 5; - addstr_(ch__17, &i__5, soutq, lsout, lnoten + 5, (ftnlen)80); -/* L127: */ - } - -/* Terminate the grace */ - -/* notexq = sq//'normalnotesize'//sq//'off{' */ -/* lnote = 20 */ -/* notexq = '}'//sq//'off{' */ -/* lnote = 6 */ -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 4, a__1[1] = "off{"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - lnote = 5; - ptoff = comask_1.wheadpt * spfacs_1.emgfac; - if ((*nacc & 3) > 0 && ! bit_test(*nacc,17)) { - ptoff += comask_1.wheadpt * spfacs_1.accfac; - } - if (isgaft && ! iswaft) { -/* Writing concatenation */ - i__2[0] = 5, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "-"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - lnote = 6; - ptoff = comgrace_1.aftshft; - } - if (normsp) { - ptoff = finalshift; - } - if (ptoff < 9.95f) { - i__1 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 3 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(f3.1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += 3; - } else if (ptoff < 99.95f) { - i__1 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 4 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(f4.1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += 4; - } else { - i__1 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 5 - i__1; - ici__1.iciunit = notexq + i__1; - ici__1.icifmt = "(f5.1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += 5; - } -/* Writing concatenation */ - i__2[0] = lnote, a__1[0] = notexq; - i__2[1] = 3, a__1[1] = "pt}"; - s_cat(ch__18, a__1, i__2, &c__2, (ftnlen)82); - i__1 = lnote + 3; - addstr_(ch__18, &i__1, soutq, lsout, lnote + 3, (ftnlen)80); - if (isgaft && ! iswaft) { -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 2, a__1[1] = "sk"; - s_cat(ch__19, a__1, i__2, &c__2, (ftnlen)3); - addstr_(ch__19, &c__3, soutq, lsout, (ftnlen)3, (ftnlen)80); - } -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = sq; - i__2[1] = 9, a__1[1] = "resetsize"; - s_cat(ch__20, a__1, i__2, &c__2, (ftnlen)10); - addstr_(ch__20, &c__10, soutq, lsout, (ftnlen)10, (ftnlen)80); - } - return 0; -} /* dograce_ */ - -/* Subroutine */ int dopsslur_(integer *nolev, integer *isdat1, integer * - isdat2, integer *isdat3, integer *isdat4, integer *nsdat, integer *ip, - integer *iv, integer *kv, integer *nv, logical *beamon, integer *ncm, - char *soutq, integer *lsout, char *ulq, integer *islur, integer *ipl, - integer *iornq, integer *islhgt, real *tno, integer *nacc, ftnlen - soutq_len, ftnlen ulq_len) -{ - /* System generated locals */ - address a__1[3], a__2[4], a__3[2]; - integer i__1, i__2, i__3[3], i__4[4], i__5[2], i__6; - char ch__1[1], ch__2[1], ch__3[6], ch__4[9]; - icilist ici__1; - - /* Builtin functions */ - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), - e_wsfe(void); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, - char **, integer *, integer *, ftnlen); - integer s_wsfi(icilist *), e_wsfi(void); - - /* Local variables */ - static integer ivoffinc; - extern integer igetbits_(integer *, integer *, integer *); - static integer j, icm; - extern integer log2_(integer *); - static integer imid; - extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char * - , ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *, - integer *, integer *, integer *, integer *, integer *); - extern integer lfmt1_(real *); - extern /* Subroutine */ int stop1_(void); - static integer ihoff; - static logical iscrd; - static integer isdat, ivoff; - static real shift; - static integer iupdn, lform, lnote; - static logical pstie; - static char noteq[8]; - static integer idcode, isdata; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen); - static logical settie; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static integer lnoten, nolevs; - static logical stemup; - static char notexq[79]; - extern /* Subroutine */ int setbits_(integer *, integer *, integer *, - integer *); - static integer numdrop; - static char slurudq[1]; - - /* Fortran I/O blocks */ - static cilist io___418 = { 0, 6, 0, 0, 0 }; - static cilist io___419 = { 0, 6, 0, 0, 0 }; - static cilist io___420 = { 0, 15, 0, "(/,a)", 0 }; - static cilist io___428 = { 0, 6, 0, 0, 0 }; - - - -/* Called once per main note. */ -/* 12 May 2002 Create this subroutine to isolate postscript slurs/ties. */ -/* Always set \Nosluradjust\Notieadjust */ - - -/* Bits in isdat1: */ -/* 13-17 iv */ -/* 3-10 ip */ -/* 11 start/stop switch */ -/* 12 kv-1 */ -/* 19-25 ichar(code$) */ -/* 26 force direction? */ -/* 27 forced dir'n = up if on, set in sslur; also */ -/* final direction, set in doslur when beam is started, used on term. */ -/* 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. */ -/* 18 int(ndxslur/16), ditto. So this allows ndxslur>15. */ - -/* Bits in isdat2 */ -/* 0 Chord switch. Not set on main note. */ -/* 1-2 left/right notehead shift. Set only for chord note. */ -/* 3 tie positioning */ -/* 4 dotted flag */ -/* 6-11 voff1 1-63 => -31...+31 */ -/* 12-18 hoff1 1-127 => -6.3...+6.3 */ -/* 19-25 nolev */ -/* 26 \sluradjust (p+s) */ -/* 27 \nosluradjust (p-s) */ -/* 28 \tieadjust (p+t) */ -/* 29 \notieadjust (p-t) */ - -/* Bits in isdat3: Only used for slur endings */ -/* 0 set if midslur (at least one argument) */ -/* 1 set if curve (2 more args) */ -/* 2-7 32+first arg (height correction) (1st arg may be negative) */ -/* 8-10 second arg (initial slope) */ -/* 11-13 third arg (closing slope) */ -/* 14-21 tie level for use in LineBreakTies */ -/* 22-29 ncm for use in LineBreakTies */ - -/* Bits in isdat4 Only used for linebreak slurs */ -/* 0-5 Linebreak seg 1 voff 1-63 => -31...+31 */ -/* 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 */ -/* 16-21 Linebreak seg 2 voff 1-63 => -31...+31 */ -/* 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 */ - -/* In listslur bit ib is on if slur index ib is in use, ib=0-13. */ -/* ndxslur = slur index */ -/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */ -/* s-slur is blank (idcode=32), t-slur is idcode=1. */ -/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */ -/* Ivoff will be set for ./_ only if no user-defined shift is specified. */ -/* If highest note has upslur, save slur height in islhgt in case */ -/* ornament must be moved. */ - - /* Parameter adjustments */ - --isdat4; - --isdat3; - --isdat2; - --isdat1; - - /* Function Body */ - *islhgt = 0; - if (*beamon) { - stemup = *(unsigned char *)ulq == 'u'; - } else if (commvl_1.nvmx[*iv - 1] == 2) { - if (! bit_test(*islur,30)) { - -/* Single note, 2 lines of music, stem direction not forced */ - - stemup = commvl_1.ivx > *nv; - } else { - stemup = bit_test(*islur,17); - } - } else { - udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], & - commvl_1.ivx, nv); - stemup = *(unsigned char *)&ch__1[0] == 'u'; - } - iscrd = bit_test(*ipl,10); - if (commidi_1.ismidi) { - settie = FALSE_; - comslm_1.dbltie = FALSE_; - } - i__1 = *nsdat; - for (isdat = 1; isdat <= i__1; ++isdat) { - isdata = isdat1[isdat]; - if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(& - isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, & - c__12) + 1) { - -/* Since iv and kv match, ivx will be correct */ - - idcode = igetbits_(&isdata, &c__7, &c__19); - ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32; - ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64; - iupdn = 0; - *(unsigned char *)slurudq = 'd'; - nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); - pstie = bit_test(isdat2[isdat],3) || idcode == 1; - if (bit_test(isdata,11)) { - -/* Turnon */ - -/* if (nolevs.eq.0 .or. nolevs.gt.60) then */ -/* c */ -/* c Note was a rest, cannot start slur on rest. */ -/* c */ -/* print* */ -/* call printl('Cannot start slur on a rest') */ -/* call stop1() */ -/* nolevs = ncm+5 */ -/* end if */ - -/* Get slur direction */ - - if (bit_test(isdata,26)) { - -/* Force slur direction */ - - if (bit_test(isdata,27)) { - *(unsigned char *)slurudq = 'u'; - } - } else if (commvl_1.nvmx[*iv - 1] == 1) { - -/* Only one voice per line */ - - if (! (*beamon)) { - -/* Separate note. */ - - udfq_(ch__1, (ftnlen)1, nolev, ncm); - *(unsigned char *)slurudq = *(unsigned char *)&ch__1[ - 0]; - } else { - -/* In a beam */ - - if (*(unsigned char *)ulq != 'u') { - *(unsigned char *)slurudq = 'u'; - } - } - if (iscrd) { - if (nolevs > *ncm) { - *(unsigned char *)slurudq = 'u'; - } else { - *(unsigned char *)slurudq = 'd'; - } - } - } else { - -/* Two voices per line. Get default */ - - if (commvl_1.ivx > *nv) { - *(unsigned char *)slurudq = 'u'; - } - -/* Upper voice of the two, so up slur */ - - } - -/* Set level for slur starting on rest */ - - if (nolevs == 0 || nolevs > 60) { - if (*(unsigned char *)slurudq == 'u') { - nolevs = *ncm + 2; - } else { - nolevs = *ncm - 2; - } - } - -/* Save up/down-ness for use at termination */ - - if (*(unsigned char *)slurudq == 'u') { - isdata = bit_set(isdata,27); - } - -/* End of section for setting slur direction, still in "Turnon" if-block. */ - - if (bit_test(*iornq,11) || bit_test(*iornq,12)) { - -/* Raise or lower slur by one unit provided . or _ is on same side as slur */ - - ivoffinc = 0; - if (stemup && *(unsigned char *)slurudq == 'd' || ! - stemup && *(unsigned char *)slurudq == 'u') { - -/* Must move the slur for _ or . */ - - if (stemup) { - ivoffinc = -1; - } else { - ivoffinc = 1; - } - if ((stemup && *nolev >= *ncm - 2 || ! stemup && * - nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, - abs(i__2)) % 2 == 0) { - ivoffinc <<= 1; - } - ivoff += ivoffinc; - } - } - if (comslur_1.listslur == 16777215) { - s_wsle(&io___418); - e_wsle(); - s_wsle(&io___419); - do_lio(&c__9, &c__1, "You1 defined the twentyfifth slur," - " one too many!", (ftnlen)48); - e_wsle(); - s_wsfe(&io___420); - do_fio(&c__1, "You defined the twentyfifth slur, one too" - " many!", (ftnlen)47); - e_wsfe(); - stop1_(); - } - -/* Get index of next slur not in use, starting from 12 down */ - - i__2 = 16777215 - comslur_1.listslur; - comslur_1.ndxslur = log2_(&i__2); -/* write(*,'()') */ -/* write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur */ - -/* Record slur index */ - - comslur_1.listslur = bit_set(comslur_1.listslur, - comslur_1.ndxslur); -/* write(*,'(10x,B24)')listslur */ - -/* Save for use on termination */ - -/* call setbits(isdata,4,28,ndxslur) */ -/* 080531 Allow >16 slurs */ - i__2 = comslur_1.ndxslur % 16; - setbits_(&isdata, &c__4, &c__28, &i__2); - i__2 = comslur_1.ndxslur / 16; - setbits_(&isdata, &c__1, &c__18, &i__2); - -/* Shift for stem? */ - - if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f) - { - if (! pstie) { - ihoff += 8; - } else { - ihoff += 2; - } - } - if (iscrd) { - -/* Additional horiz shifts for h-shifted noteheads? */ - - if (bit_test(isdat2[isdat],1)) { - -/* Slur start on left-shifted chord notehead. ASSUME downstem. */ - - if (nolevs == comtrill_1.minlev && *(unsigned char *) - slurudq == 'd') { - ihoff += -2; - } else { - ihoff += -10; - } - } else if (bit_test(isdat2[isdat],2)) { - -/* Right shifted chord notehead. ASSUME upstem. */ - - if (nolevs == comtrill_1.maxlev && *(unsigned char *) - slurudq == 'u') { - ihoff += 2; - } else { - ihoff += 10; - } - } - } - chax_(ch__1, (ftnlen)1, &c__92); - s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1); - lnote = 1; - -/* Check for local adjustment default changes */ - - if (bit_test(isdat2[isdat],26)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 10, a__1[1] = "sluradjust"; - chax_(ch__2, (ftnlen)1, &c__92); - i__3[2] = 1, a__1[2] = ch__2; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 12; - } else if (bit_test(isdat2[isdat],27)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 12, a__1[1] = "nosluradjust"; - chax_(ch__2, (ftnlen)1, &c__92); - i__3[2] = 1, a__1[2] = ch__2; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 14; - } else if (bit_test(isdat2[isdat],28)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 9, a__1[1] = "tieadjust"; - chax_(ch__2, (ftnlen)1, &c__92); - i__3[2] = 1, a__1[2] = ch__2; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 11; - } else if (bit_test(isdat2[isdat],29)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 11, a__1[1] = "notieadjust"; - chax_(ch__2, (ftnlen)1, &c__92); - i__3[2] = 1, a__1[2] = ch__2; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 13; - } - if (ihoff == 0) { - -/* Write stuff for non-shifted start */ - -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 5, a__1[1] = "islur"; - i__3[2] = 1, a__1[2] = slurudq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote += 6; - } else { -/* Writing concatenation */ - i__3[0] = lnote, a__1[0] = notexq; - i__3[1] = 2, a__1[1] = "is"; - i__3[2] = 1, a__1[2] = slurudq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote += 3; - } - -/* Prepend postscript tie switch */ - - if (pstie) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__4[0] = 1, a__2[0] = ch__1; - i__4[1] = 8, a__2[1] = "tieforis"; - i__4[2] = 1, a__2[2] = slurudq; - i__4[3] = lnote, a__2[3] = notexq; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 10; - } - if (bit_test(isdat2[isdat],4)) { - -/* Dotted slur */ - -/* noteq = notexq */ -/* notexq = chax(92)//'dotted'//noteq */ -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "dotted"; - i__3[2] = lnote, a__1[2] = notexq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote += 7; - } - -/* Add slur index to string */ -/* c Print 11-ndxslur */ -/* Print 23-ndxslur */ - -/* if (11-ndxslur .lt. 10) then */ - if (23 - comslur_1.ndxslur < 10) { - -/* 5/25/08 Allow 24 slurs */ - -/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__2 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__1; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - } else if (23 - comslur_1.ndxslur < 20) { -/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{1"; - i__2 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{2"; - i__2 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } - -/* Add note name to string */ - -/* call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) */ - *islhgt = nolevs + iupdn + ivoff; - notefq_(noteq, &lnoten, islhgt, ncm, (ftnlen)8); -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = lnoten, a__3[1] = noteq; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - lnote += lnoten; - -/* Store height and staff mid level for use with LineBreakTies */ - - setbits_(&isdat3[isdat], &c__8, &c__14, islhgt); - setbits_(&isdat3[isdat], &c__8, &c__22, ncm); - -/* Save height (for ornament and barnobox interference) if topmost slur is up */ - - if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ - isdat],0) || nolevs == comtrill_1.maxlev)) { - *islhgt = nolevs + iupdn + ivoff; - -/* Save height & idcode if top voice and slur start */ - - if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv - - 1] * 24 - 25] && *islhgt > comsln_1.is1n1) { - comsln_1.is1n1 = *islhgt; - comsln_1.is2n1 = idcode; - } - } - if ((real) ihoff != 0.f) { - shift = ihoff * .1f; -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 1, a__3[1] = "{"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - lform = lfmt1_(&shift); - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + lform - i__2; - ici__1.iciunit = notexq + i__2; -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = "(f"; - i__6 = lform + 48; - chax_(ch__1, (ftnlen)1, &i__6); - i__3[1] = 1, a__1[1] = ch__1; - i__3[2] = 3, a__1[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen) - 6), ch__3); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += lform; -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 1, a__3[1] = "}"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - -/* Zero out ip1 to avoid problems if slur goes to next input blk. */ - - setbits_(&isdata, &c__8, &c__3, &c__0); - -/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */ - - if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) { -/* levson(midchan(iv,kv)) = nolev */ - comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = - nolevs; - if (settie) { - comslm_1.dbltie = TRUE_; - } - -/* Only way settie=T is if we just set a tie ending. So there's also a slur */ -/* start here, so set a flag telling addmidi not to zero out levson */ - - } - } else { - -/* Slur is ending. Back thru list to find starting slur */ - - for (j = isdat - 1; j >= 1; --j) { - if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv == - igetbits_(&isdat1[j], &c__1, &c__12) + 1) { - if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) { - comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, & - c__28) + (igetbits_(&isdat1[j], &c__1, & - c__18) << 4); - -/* 080531 Allow >16 slurs */ - - if (bit_test(isdat1[j],27)) { - *(unsigned char *)slurudq = 'u'; - } - goto L4; - } - } -/* L3: */ - } - s_wsle(&io___428); - do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19); - e_wsle(); - stop1_(); -L4: - -/* Bugfix 070901 for slur ending on rest in 2-voice staff */ - -/* if (nolevs.eq.0 .or. nolevs.gt.60) then */ - if (nolevs <= 2 || nolevs > 60) { - -/* Ending is on a rest, reset nolevs to default starting height */ - - nolevs = igetbits_(&isdat2[j], &c__7, &c__19); - } - if (bit_test(isdat3[isdat],0) || bit_test(isdat3[j],0)) { - -/* Deal with \curve or \midslur. isdat is ending, j is start. */ - - if (bit_test(isdat3[isdat],0)) { - imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32; - } else { - imid = igetbits_(&isdat3[j], &c__6, &c__2) - 32; - } - -/* Postscript slurs, and \midslur adjustment is needed. Invoke macro */ -/* (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: */ -/* Abs(imid) Postscript slur type */ -/* 1 f */ -/* 2-3 default */ -/* 4 h */ -/* 5 H */ -/* 6+ HH */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 7, a__1[1] = "psforts"; -/* Computing MIN */ - i__6 = abs(imid); - i__2 = min(i__6,6) + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__3[2] = 1, a__1[2] = ch__2; - s_cat(ch__4, a__1, i__3, &c__3, (ftnlen)9); - addstr_(ch__4, &c__9, soutq, lsout, (ftnlen)9, (ftnlen)80) - ; - } - -/* Shift slur ending for stem on any note? */ - - if (! stemup && *(unsigned char *)slurudq == 'd' && *tno < - 63.f) { - if (! pstie) { - ihoff += -8; - } else { - ihoff += -3; - } - } - if (iscrd) { - -/* Shift termination for shifted notehead? */ - - if (bit_test(isdat2[isdat],1)) { - -/* Left-shifted chord notehead. ASSUME downstem. */ - - if (nolevs == comtrill_1.minlev && *(unsigned char *) - slurudq == 'd') { - ihoff += -2; - } else { - ihoff += -10; - } - } else if (bit_test(isdat2[isdat],2)) { - -/* Right shifted chord notehead. ASSUME upstem. */ - - if (nolevs == comtrill_1.maxlev && *(unsigned char *) - slurudq == 'u') { - ihoff += 2; - } else { - ihoff += 10; - } - } - } - if (ihoff == 0) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__5[0] = 1, a__3[0] = ch__1; - i__5[1] = 5, a__3[1] = "tslur"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - lnote = 6; - } else { - -/* Shift needed */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__5[0] = 1, a__3[0] = ch__1; - i__5[1] = 2, a__3[1] = "ts"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - lnote = 3; - } - -/* Switch to postscript tie */ - - if (pstie) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 8, a__1[1] = "tieforts"; - i__3[2] = lnote, a__1[2] = notexq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote += 9; - } - -/* Print 13-ndxslur */ -/* 5/25/08 Allow 14 slurs */ - - if (23 - comslur_1.ndxslur < 10) { -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__2 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__1; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - } else if (23 - comslur_1.ndxslur < 20) { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{1"; - i__2 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 2, a__2[1] = "{2"; - i__2 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[2] = 1, a__2[2] = ch__1; - i__4[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); - lnote += 4; - } - if (bit_test(*iornq,11) || bit_test(*iornq,12)) { - -/* Raise or lower slur by one unit provided . or _ is on same side as slur */ - - ivoffinc = 0; - if (stemup && *(unsigned char *)slurudq == 'd' || ! - stemup && *(unsigned char *)slurudq == 'u') { - if (stemup) { - ivoffinc = -1; - } else { - ivoffinc = 1; - } - if ((stemup && *nolev >= *ncm - 2 || ! stemup && * - nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, - abs(i__2)) % 2 == 0) { - ivoffinc <<= 1; - } - } - ivoff += ivoffinc; - } - i__2 = nolevs + iupdn + ivoff; - notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); - if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ - isdat],0) || nolevs == comtrill_1.maxlev)) { - *islhgt = nolevs + iupdn + ivoff; - -/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */ - - if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv - - 1] * 24 - 25] && comsln_1.is1n1 > 0) { - if (idcode == comsln_1.is2n1) { - comsln_1.is1n1 = 0; - } - } - } -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = lnoten, a__3[1] = noteq; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - lnote += lnoten; - if (ihoff != 0) { - shift = ihoff * .1f; -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 1, a__3[1] = "{"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - lform = lfmt1_(&shift); - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + lform - i__2; - ici__1.iciunit = notexq + i__2; -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = "(f"; - i__6 = lform + 48; - chax_(ch__1, (ftnlen)1, &i__6); - i__3[1] = 1, a__1[1] = ch__1; - i__3[2] = 3, a__1[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen) - 6), ch__3); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += lform; -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 1, a__3[1] = "}"; - s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); - ++lnote; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - -/* Clear the bit from list of slurs in use */ - - comslur_1.listslur = bit_clear(comslur_1.listslur, - comslur_1.ndxslur); - -/* Zero out the entire strings for start and stop */ - - isdata = 0; - isdat2[isdat] = 0; - isdat3[isdat] = 0; - isdat4[isdat] = 0; - isdat1[j] = 0; - isdat2[j] = 0; - isdat3[j] = 0; - isdat4[j] = 0; - -/* Set midi info for slur ending */ - - if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) { - icm = commidi_1.midchan[*iv + *kv * 24 - 25]; - if (comslm_1.slmon[icm]) { - if (nolevs == comslm_1.levson[icm] && (7 & *nacc) == - 0) { - -/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ - - comslm_1.levsoff[icm] = nolevs; - settie = TRUE_; - } else { - comslm_1.levsoff[icm] = 0; - comslm_1.levson[icm] = 0; - comslm_1.slmon[icm] = FALSE_; - } - } - } - } - isdat1[isdat] = isdata; - } -/* L1: */ - } - -/* Clear and collapse the slur data list */ - - numdrop = 0; - i__1 = *nsdat; - for (isdat = 1; isdat <= i__1; ++isdat) { - if (isdat1[isdat] == 0) { - ++numdrop; - } else if (numdrop > 0) { - isdat1[isdat - numdrop] = isdat1[isdat]; - isdat2[isdat - numdrop] = isdat2[isdat]; - isdat3[isdat - numdrop] = isdat3[isdat]; - isdat4[isdat - numdrop] = isdat4[isdat]; - isdat1[isdat] = 0; - isdat2[isdat] = 0; - isdat3[isdat] = 0; - isdat4[isdat] = 0; - } -/* L2: */ - } - *nsdat -= numdrop; -/* call report(nsdat,isdat1,isdat2) */ - return 0; -} /* dopsslur_ */ - -/* Subroutine */ int doslur_(integer *nolev, integer *isdat1, integer *isdat2, - integer *isdat3, integer *nsdat, integer *ip, integer *iv, integer * - kv, integer *nv, logical *beamon, integer *ncm, char *soutq, integer * - lsout, char *ulq, integer *islur, integer *ipl, integer *iornq, - integer *islhgt, real *tno, integer *nacc, ftnlen soutq_len, ftnlen - ulq_len) -{ - /* System generated locals */ - address a__1[3], a__2[2], a__3[4]; - integer i__1, i__2, i__3[3], i__4[2], i__5[4], i__6; - char ch__1[1], ch__2[6]; - icilist ici__1; - - /* Builtin functions */ - integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char - *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), - e_wsfe(void); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), - s_copy(char *, char *, ftnlen, ftnlen); - integer s_wsfi(icilist *), e_wsfi(void); - - /* Local variables */ - static integer ivoffinc; - extern integer igetbits_(integer *, integer *, integer *); - static integer j, icm; - extern integer log2_(integer *); - static integer imid; - extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char * - , ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *, - integer *, integer *, integer *, integer *, integer *); - extern integer lfmt1_(real *); - extern /* Subroutine */ int stop1_(void); - static integer ihoff; - static logical iscrd; - static integer isdat, ivoff; - static real shift; - static integer iupdn, lform, lnote; - static char noteq[8]; - static logical tmove; - static integer idcode, isdata; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen); - static integer isdats; - static logical settie, sfound, tfound; - static integer isdatt; - extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer - *, ftnlen); - static integer lnoten, nolevt, nolevs; - extern /* Subroutine */ int printl_(char *, ftnlen); - static logical stemup; - static char notexq[79]; - extern /* Subroutine */ int setbits_(integer *, integer *, integer *, - integer *); - static integer numdrop; - static char slurudq[1]; - - /* Fortran I/O blocks */ - static cilist io___449 = { 0, 6, 0, 0, 0 }; - static cilist io___451 = { 0, 6, 0, 0, 0 }; - static cilist io___452 = { 0, 6, 0, 0, 0 }; - static cilist io___453 = { 0, 15, 0, "(/,a)", 0 }; - static cilist io___461 = { 0, 6, 0, 0, 0 }; - - - -/* Called once per main note. (5/26/02) for non-ps slurs only */ - - -/* Bits in isdat1: */ -/* 13-17 iv */ -/* 3-10 ip */ -/* 11 start/stop switch */ -/* 12 kv-1 */ -/* 19-25 ichar(code$) */ -/* 26 force direction? */ -/* 27 forced dir'n = up if on, set in sslur; also */ -/* final direction, set in doslur when beam is started, used on term. */ -/* 28-31 ndxslur, set in doslur when beam is started, used on term. */ - -/* Bits in isdat2 */ -/* 0 Chord switch. Not set on main note. */ -/* 1-2 left/right notehead shift. Set only for chord note. */ -/* 3 tie positioning */ -/* 4 dotted flag */ -/* 6-11 voff1 1-63 => -31...+31 */ -/* 12-18 hoff1 1-127 => -6.3...+6.3 */ -/* 19-25 nolev */ - -/* Bits in isdat3: Only used for slur endings */ -/* 0 set if midslur (at least one argument) */ -/* 1 set if curve (2 more args) */ -/* 2-7 32+first arg (height correction) (1st arg may be negative) */ -/* 8-10 second arg (initial slope) */ -/* 11-13 third arg (closing slope) */ - -/* In listslur bit ib is on if slur index ib is in use, ib=0-23. */ -/* ndxslur = slur index */ -/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */ -/* s-slur is blank (idcode=32), t-slur is idcode=1. */ -/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */ -/* Ivoff will be set for ./_ only if no user-defined shift is specified. */ -/* If highest note has upslur, save slur height in islhgt in case */ -/* ornament must be moved. */ - - /* Parameter adjustments */ - --isdat3; - --isdat2; - --isdat1; - - /* Function Body */ - *islhgt = 0; - if (*beamon) { - stemup = *(unsigned char *)ulq == 'u'; - } else if (commvl_1.nvmx[*iv - 1] == 2) { - if (! bit_test(*islur,30)) { - -/* Single note, 2 lines of music, stem direction not forced */ - - stemup = commvl_1.ivx > *nv; - } else { - stemup = bit_test(*islur,17); - } - } else { - udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], & - commvl_1.ivx, nv); - stemup = *(unsigned char *)&ch__1[0] == 'u'; - } - iscrd = bit_test(*ipl,10); - if (bit_test(*islur,1)) { - -/* 't'-slur (idcode=1) somewhere on this note. Find it, check height against */ -/* 's'-slur (idcode=32) */ - - sfound = FALSE_; - tfound = FALSE_; - tmove = FALSE_; - i__1 = *nsdat; - for (isdat = 1; isdat <= i__1; ++isdat) { - if (*iv == igetbits_(&isdat1[isdat], &c__5, &c__13) && *ip == - igetbits_(&isdat1[isdat], &c__8, &c__3) && *kv == - igetbits_(&isdat1[isdat], &c__1, &c__12) + 1) { - if (! tfound) { - tfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 1; - if (tfound) { - nolevt = igetbits_(&isdat2[isdat], &c__7, &c__19); - isdatt = isdat; - if (sfound) { - goto L6; - } - } - } - if (! sfound) { - sfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 32; - if (sfound) { - nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); - isdats = isdat; - if (tfound) { - goto L6; - } - } - } - } -/* L5: */ - } - -/* Will come thru here if there is a t with no s, so comment out the following */ -/* print*,'Did not find s+t-slurs in doslur' */ - -L6: - if (sfound && tfound) { - tmove = nolevs == nolevt && (bit_test(isdat1[isdats],11) && - bit_test(isdat1[isdatt],11) || ! bit_test(isdat1[isdats], - 11) && ! bit_test(isdat1[isdatt],11)); - } - -/* Check if 2 starts or two stops */ - - -/* This is a flag for later changing slur level, after we know slur dir'n. */ - - } - if (commidi_1.ismidi) { - settie = FALSE_; - comslm_1.dbltie = FALSE_; - } - i__1 = *nsdat; - for (isdat = 1; isdat <= i__1; ++isdat) { - isdata = isdat1[isdat]; - if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(& - isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, & - c__12) + 1) { - -/* Since iv and kv match, ivx will be correct */ - - idcode = igetbits_(&isdata, &c__7, &c__19); - ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32; - ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64; - iupdn = 0; - *(unsigned char *)slurudq = 'd'; - nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); - if (bit_test(isdata,11)) { - -/* Turnon, */ - - if (nolevs == 0 || nolevs > 60) { - -/* Note was a rest, cannot start slur on rest. */ - - s_wsle(&io___449); - e_wsle(); - printl_("Cannot start slur on a rest", (ftnlen)27); - stop1_(); - } - -/* Get slur direction */ - - if (bit_test(isdata,26)) { - -/* Force slur direction */ - - if (bit_test(isdata,27)) { - *(unsigned char *)slurudq = 'u'; - } - } else if (commvl_1.nvmx[*iv - 1] == 1) { - -/* Only one voice per line */ - - if (! (*beamon)) { - -/* Separate note. */ - - udfq_(ch__1, (ftnlen)1, nolev, ncm); - *(unsigned char *)slurudq = *(unsigned char *)&ch__1[ - 0]; - } else { - -/* In a beam */ - - if (*(unsigned char *)ulq != 'u') { - *(unsigned char *)slurudq = 'u'; - } - } - if (iscrd) { - if (nolevs > *ncm) { - *(unsigned char *)slurudq = 'u'; - } else { - *(unsigned char *)slurudq = 'd'; - } - } - } else { - -/* Two voices per line. Get default */ - - if (commvl_1.ivx > *nv) { - *(unsigned char *)slurudq = 'u'; - } - -/* Upper voice of the two, so up slur */ - - } - -/* Save up/down-ness for use at termination */ - - if (*(unsigned char *)slurudq == 'u') { - isdata = bit_set(isdata,27); - } - -/* End of section for setting slur direction, still in "Turnon" if-block. */ - - if (idcode == 1 && tmove) { - iupdn = 1; - if (*(unsigned char *)slurudq == 'd') { - iupdn = -1; - } - } - if (bit_test(*iornq,11) || bit_test(*iornq,12)) { - -/* Raise or lower slur by one unit provided . or _ is on same side as slur */ - - ivoffinc = 0; - if (stemup && *(unsigned char *)slurudq == 'd' || ! - stemup && *(unsigned char *)slurudq == 'u') { - -/* Must move the slur for _ or . */ - - if (stemup) { - ivoffinc = -1; - } else { - ivoffinc = 1; - } - if ((stemup && *nolev >= *ncm - 2 || ! stemup && * - nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, - abs(i__2)) % 2 == 0) { - ivoffinc <<= 1; - } - ivoff += ivoffinc; - } - } - if (comslur_1.listslur == 16777215) { - s_wsle(&io___451); - e_wsle(); - s_wsle(&io___452); - do_lio(&c__9, &c__1, "You1 defined the twenty-fifth slur" - ", one too many!", (ftnlen)49); - e_wsle(); - s_wsfe(&io___453); - do_fio(&c__1, "You2 defined the twenty-fifth slur, one t" - "oo many!", (ftnlen)49); - e_wsfe(); - stop1_(); - } - -/* Get index of next slur not in use, starting from ? down */ - - i__2 = 16777215 - comslur_1.listslur; - comslur_1.ndxslur = log2_(&i__2); - -/* Record slur index */ - - comslur_1.listslur = bit_set(comslur_1.listslur, - comslur_1.ndxslur); - -/* Save for use on termination */ - -/* call setbits(isdata,4,28,ndxslur) */ -/* 080531 Allow >16 slurs */ - i__2 = comslur_1.ndxslur % 16; - setbits_(&isdata, &c__4, &c__28, &i__2); - i__2 = comslur_1.ndxslur / 16; - setbits_(&isdata, &c__1, &c__18, &i__2); - -/* Shift for stem? */ - - if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f) - { - ihoff += 8; - } - if (bit_test(isdat2[isdat],3)) { - -/* Tie spacing, (slur start) */ - - if (*(unsigned char *)slurudq == 'd') { - ++ivoff; - ihoff += 8; - } else if (*(unsigned char *)slurudq == 'u') { - --ivoff; - if (! (stemup && *tno < 63.f)) { - ihoff += 8; - } - -/* (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') */ - - } - } - if (iscrd) { - -/* Additional horiz shifts for h-shifted noteheads? */ - - if (bit_test(isdat2[isdat],1)) { - -/* Slur start on left-shifted chord notehead. ASSUME downstem. */ - - if (nolevs == comtrill_1.minlev && *(unsigned char *) - slurudq == 'd') { - ihoff += -2; - } else { - ihoff += -10; - } - } else if (bit_test(isdat2[isdat],2)) { - -/* Right shifted chord notehead. ASSUME upstem. */ - - if (nolevs == comtrill_1.maxlev && *(unsigned char *) - slurudq == 'u') { - ihoff += 2; - } else { - ihoff += 10; - } - } - } - if (ihoff == 0) { - -/* Write stuff for non-shifted start */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 5, a__1[1] = "islur"; - i__3[2] = 1, a__1[2] = slurudq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 7; - } else { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 2, a__1[1] = "is"; - i__3[2] = 1, a__1[2] = slurudq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote = 4; - } - if (bit_test(isdat2[isdat],4)) { - -/* Dotted slur */ - - s_copy(noteq, notexq, (ftnlen)8, (ftnlen)79); -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__3[0] = 1, a__1[0] = ch__1; - i__3[1] = 6, a__1[1] = "dotted"; - i__3[2] = 8, a__1[2] = noteq; - s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); - lnote += 7; - } - -/* Add slur index to string */ -/* c Print 11-ndxslur */ -/* Print 23-ndxslur */ - -/* if (11-ndxslur .lt. 10) then */ - if (23 - comslur_1.ndxslur < 10) { - -/* 5/25/08 Allow 24 slurs */ - -/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__2 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[1] = 1, a__2[1] = ch__1; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - } else if (23 - comslur_1.ndxslur < 20) { -/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 2, a__3[1] = "{1"; - i__2 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[2] = 1, a__3[2] = ch__1; - i__5[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 2, a__3[1] = "{2"; - i__2 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[2] = 1, a__3[2] = ch__1; - i__5[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); - lnote += 4; - } - -/* Add note name to string */ - - i__2 = nolevs + iupdn + ivoff; - notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = lnoten, a__2[1] = noteq; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote += lnoten; - -/* Save height (for ornament and barnobox interference) if topmost slur is up */ - - if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ - isdat],0) || nolevs == comtrill_1.maxlev)) { - *islhgt = nolevs + iupdn + ivoff; - -/* Save height & idcode if top voice and slur start */ - - if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv - - 1] * 24 - 25] && *islhgt > comsln_1.is1n1) { - comsln_1.is1n1 = *islhgt; - comsln_1.is2n1 = idcode; - } - } - if ((real) ihoff != 0.f) { - shift = ihoff * .1f; -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "{"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - lform = lfmt1_(&shift); - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + lform - i__2; - ici__1.iciunit = notexq + i__2; -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = "(f"; - i__6 = lform + 48; - chax_(ch__1, (ftnlen)1, &i__6); - i__3[1] = 1, a__1[1] = ch__1; - i__3[2] = 3, a__1[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen) - 6), ch__2); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += lform; -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - -/* Zero out ip1 to avoid problems if slur goes to next input blk. */ - - setbits_(&isdata, &c__8, &c__3, &c__0); - -/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */ - - if (commidi_1.ismidi && idcode == 32) { - comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = - nolevs; - if (settie) { - comslm_1.dbltie = TRUE_; - } - -/* Only way settie=T is if we just set a tie ending. So there's also a slur */ -/* start here, so set a flag telling addmidi not to zero out levson */ - - } - } else { - -/* Slur is ending. Back thru list to find starting slur */ - - for (j = isdat - 1; j >= 1; --j) { - if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv == - igetbits_(&isdat1[j], &c__1, &c__12) + 1) { - if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) { - comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, & - c__28) + (igetbits_(&isdat1[j], &c__1, & - c__18) << 4); - -/* 080531 Allow >16 slurs */ - - if (bit_test(isdat1[j],27)) { - *(unsigned char *)slurudq = 'u'; - } - goto L4; - } - } -/* L3: */ - } - s_wsle(&io___461); - do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19); - e_wsle(); - stop1_(); -L4: - if (nolevs == 0 || nolevs > 60) { - -/* Ending is on a rest, reset nolevs to default starting height */ - - nolevs = igetbits_(&isdat2[j], &c__7, &c__19); - } - if (bit_test(isdat3[isdat],0)) { - -/* Deal with \curve or \midslur */ - - imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32; - -/* Remember, only dealing with non-ps slurs */ - -/* Who knows where the following line came from. Removed it 6/30/02 to */ -/* restore behavior of non-ps slurs to old way */ -/* if (slurudq .eq. 'd') imid = -imid */ -/* 3/8/03 added the following */ - - if (*(unsigned char *)slurudq == 'd') { - imid = -abs(imid); - } - - if (bit_test(isdat3[isdat],1)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__4[0] = 1, a__2[0] = ch__1; - i__4[1] = 5, a__2[1] = "curve"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote = 6; - } else { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__4[0] = 1, a__2[0] = ch__1; - i__4[1] = 7, a__2[1] = "midslur"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote = 8; - } - if (imid < 0 || imid > 9) { - -/* Need brackets */ - -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "{"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - if (imid < -9) { - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 3 - i__2; - ici__1.iciunit = notexq + i__2; - ici__1.icifmt = "(i3)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( - integer)); - e_wsfi(); - lnote += 3; - } else if (imid < 0 || imid > 9) { - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 2 - i__2; - ici__1.iciunit = notexq + i__2; - ici__1.icifmt = "(i2)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( - integer)); - e_wsfi(); - lnote += 2; - } else { - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + 1 - i__2; - ici__1.iciunit = notexq + i__2; - ici__1.icifmt = "(i1)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( - integer)); - e_wsfi(); - ++lnote; - } -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - } else { - -/* 1= 63.f) { - ihoff += -8; - } - } - } - if (iscrd) { - -/* Shift termination for shifted notehead? */ - - if (bit_test(isdat2[isdat],1)) { - -/* Left-shifted chord notehead. ASSUME downstem. */ - - if (nolevs == comtrill_1.minlev && *(unsigned char *) - slurudq == 'd') { - ihoff += -2; - } else { - ihoff += -10; - } - } else if (bit_test(isdat2[isdat],2)) { - -/* Right shifted chord notehead. ASSUME upstem. */ - - if (nolevs == comtrill_1.maxlev && *(unsigned char *) - slurudq == 'u') { - ihoff += 2; - } else { - ihoff += 10; - } - } - } - if (ihoff == 0) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__4[0] = 1, a__2[0] = ch__1; - i__4[1] = 5, a__2[1] = "tslur"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote = 6; - } else { - -/* Shift needed */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__4[0] = 1, a__2[0] = ch__1; - i__4[1] = 2, a__2[1] = "ts"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote = 3; - } - -/* Print 23-ndxslur */ -/* 5/25/08 Allow 14 slurs (???????????) */ - - if (23 - comslur_1.ndxslur < 10) { -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__2 = 71 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__4[1] = 1, a__2[1] = ch__1; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - } else if (23 - comslur_1.ndxslur < 20) { -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 2, a__3[1] = "{1"; - i__2 = 61 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[2] = 1, a__3[2] = ch__1; - i__5[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__5[0] = lnote, a__3[0] = notexq; - i__5[1] = 2, a__3[1] = "{2"; - i__2 = 51 - comslur_1.ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__5[2] = 1, a__3[2] = ch__1; - i__5[3] = 1, a__3[3] = "}"; - s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); - lnote += 4; - } - if (bit_test(*iornq,11) || bit_test(*iornq,12)) { - -/* Raise or lower slur by one unit provided . or _ is on same side as slur */ - - ivoffinc = 0; - if (stemup && *(unsigned char *)slurudq == 'd' || ! - stemup && *(unsigned char *)slurudq == 'u') { - if (stemup) { - ivoffinc = -1; - } else { - ivoffinc = 1; - } - if ((stemup && *nolev >= *ncm - 2 || ! stemup && * - nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, - abs(i__2)) % 2 == 0) { - ivoffinc <<= 1; - } - } - ivoff += ivoffinc; - } - if (idcode == 1 && tmove) { - -/* t-slur height adjustment */ - - iupdn = 1; - if (*(unsigned char *)slurudq == 'd') { - iupdn = -1; - } - } - i__2 = nolevs + iupdn + ivoff; - notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); - if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ - isdat],0) || nolevs == comtrill_1.maxlev)) { - *islhgt = nolevs + iupdn + ivoff; - -/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */ - - if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv - - 1] * 24 - 25] && comsln_1.is1n1 > 0) { - if (idcode == comsln_1.is2n1) { - comsln_1.is1n1 = 0; - } - } - } -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = lnoten, a__2[1] = noteq; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - lnote += lnoten; - if (ihoff != 0) { - shift = ihoff * .1f; -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "{"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - lform = lfmt1_(&shift); - i__2 = lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = lnote + lform - i__2; - ici__1.iciunit = notexq + i__2; -/* Writing concatenation */ - i__3[0] = 2, a__1[0] = "(f"; - i__6 = lform + 48; - chax_(ch__1, (ftnlen)1, &i__6); - i__3[1] = 1, a__1[1] = ch__1; - i__3[2] = 3, a__1[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen) - 6), ch__2); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); - e_wsfi(); - lnote += lform; -/* Writing concatenation */ - i__4[0] = lnote, a__2[0] = notexq; - i__4[1] = 1, a__2[1] = "}"; - s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); - ++lnote; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - -/* Clear the bit from list of slurs in use */ - - comslur_1.listslur = bit_clear(comslur_1.listslur, - comslur_1.ndxslur); - -/* Zero out the entire strings for start and stop */ - - isdata = 0; - isdat2[isdat] = 0; - isdat1[j] = 0; - isdat2[j] = 0; - isdat3[isdat] = 0; - -/* Set midi info for slur ending */ - - if (commidi_1.ismidi && idcode == 32) { - icm = commidi_1.midchan[*iv + *kv * 24 - 25]; - if (comslm_1.slmon[icm]) { - if (nolevs == comslm_1.levson[icm] && (7 & *nacc) == - 0) { - -/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ - - comslm_1.levsoff[icm] = nolevs; - settie = TRUE_; - } else { - comslm_1.levsoff[icm] = 0; - comslm_1.levson[icm] = 0; - comslm_1.slmon[icm] = FALSE_; - } - } - } - } - isdat1[isdat] = isdata; - } -/* L1: */ - } - -/* Clear and collapse the slur data list */ - - numdrop = 0; - i__1 = *nsdat; - for (isdat = 1; isdat <= i__1; ++isdat) { - if (isdat1[isdat] == 0) { - ++numdrop; - } else if (numdrop > 0) { - isdat1[isdat - numdrop] = isdat1[isdat]; - isdat2[isdat - numdrop] = isdat2[isdat]; - isdat3[isdat - numdrop] = isdat3[isdat]; - isdat1[isdat] = 0; - isdat2[isdat] = 0; - isdat3[isdat] = 0; - } -/* L2: */ - } - *nsdat -= numdrop; -/* call report(nsdat,isdat1,isdat2) */ - return 0; -} /* doslur_ */ - -/* Subroutine */ int dotmov_(real *updot, real *rtdot, char *soutq, integer * - lsout, integer *iddot, ftnlen soutq_len) -{ - /* System generated locals */ - address a__1[5], a__2[8], a__3[5]; - integer i__1[5], i__2, i__3, i__4[8], i__5[5], i__6; - char ch__1[1], ch__2[22], ch__3[1], ch__4[37], ch__5[15], ch__6[1]; - icilist ici__1; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) - ; - - /* Local variables */ - static char sq[1]; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - extern integer lfmt1_(real *); - static integer lnote; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen); - static integer lfmtup, lfmtrt; - static char notexq[80]; - - -/* iddot = 0 for single dot, 1 for double */ - - chax_(ch__1, (ftnlen)1, &c__92); - *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; - lfmtup = lfmt1_(updot); - lfmtrt = lfmt1_(rtdot); - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 80; - ici__1.iciunit = notexq; -/* Writing concatenation */ - i__1[0] = 6, a__1[0] = "(a37,f"; - i__2 = lfmtup + 48; - chax_(ch__1, (ftnlen)1, &i__2); - i__1[1] = 1, a__1[1] = ch__1; - i__1[2] = 7, a__1[2] = ".1,a2,f"; - i__3 = lfmtrt + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__1[3] = 1, a__1[3] = ch__3; - i__1[4] = 7, a__1[4] = ".1,a15)"; - ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__5, (ftnlen)22), ch__2); - s_wsfi(&ici__1); -/* Writing concatenation */ - i__4[0] = 1, a__2[0] = sq; - i__4[1] = 12, a__2[1] = "makeatletter"; - i__4[2] = 1, a__2[2] = sq; - i__4[3] = 3, a__2[3] = "def"; - i__4[4] = 1, a__2[4] = sq; - i__4[5] = 12, a__2[5] = "C@Point#1#2{"; - i__4[6] = 1, a__2[6] = sq; - i__4[7] = 6, a__2[7] = "PMXpt{"; - s_cat(ch__4, a__2, i__4, &c__8, (ftnlen)37); - do_fio(&c__1, ch__4, (ftnlen)37); - do_fio(&c__1, (char *)&(*updot), (ftnlen)sizeof(real)); - do_fio(&c__1, "}{", (ftnlen)2); - do_fio(&c__1, (char *)&(*rtdot), (ftnlen)sizeof(real)); -/* Writing concatenation */ - i__5[0] = 1, a__3[0] = "}"; - i__6 = *iddot + 48; - chax_(ch__6, (ftnlen)1, &i__6); - i__5[1] = 1, a__3[1] = ch__6; - i__5[2] = 1, a__3[2] = "}"; - i__5[3] = 1, a__3[3] = sq; - i__5[4] = 11, a__3[4] = "makeatother"; - s_cat(ch__5, a__3, i__5, &c__5, (ftnlen)15); - do_fio(&c__1, ch__5, (ftnlen)15); - e_wsfi(); - -/* Example of string just created: */ -/* \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\ */ - - lnote = lfmtup + 54 + lfmtrt; - addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80); - return 0; -} /* dotmov_ */ - -/* Subroutine */ int dotrill_(integer *iv, integer *ip, integer *iornq, char * - noteq, integer *lnoten, char *notexq, integer *lnote, ftnlen - noteq_len, ftnlen notexq_len) -{ - /* System generated locals */ - address a__1[2], a__2[3]; - integer i__1, i__2[2], i__3[3], i__4; - char ch__1[1], ch__2[6]; - icilist ici__1; - - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - /* Subroutine */ int s_stop(char *, ftnlen), s_cat(char *, char **, - integer *, integer *, ftnlen); - integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) - ; - - /* Local variables */ - static integer itr; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static integer nfmt; - static logical tronly; - - /* Fortran I/O blocks */ - static cilist io___471 = { 0, 6, 0, 0, 0 }; - - - i__1 = comtrill_1.ntrill; - for (itr = 1; itr <= i__1; ++itr) { - if (*iv == comtrill_1.ivtrill[itr - 1] && *ip == comtrill_1.iptrill[ - itr - 1]) { - goto L2; - } -/* L1: */ - } - s_wsle(&io___471); - do_lio(&c__9, &c__1, "Problem in dotrill. Call Dr. Don", (ftnlen)33); - e_wsle(); - s_stop("", (ftnlen)0); -L2: - tronly = comtrill_1.xnsktr[itr - 1] < .01f; - if (tronly) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = 9, a__1[1] = "zcharnote"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - *lnote = 10; - } else if (bit_test(*iornq,7)) { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = 6, a__1[1] = "Trille"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - *lnote = 7; - } else { -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__2[0] = 1, a__1[0] = ch__1; - i__2[1] = 6, a__1[1] = "trille"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - *lnote = 7; - } -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - i__3[1] = *lnoten, a__2[1] = noteq; - i__3[2] = 1, a__2[2] = "{"; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - *lnote = *lnote + *lnoten + 1; - -/* Write trill duration to nearest tenth of a noteskip */ - - if (tronly) { -/* Writing concatenation */ - i__3[0] = *lnote, a__2[0] = notexq; - chax_(ch__1, (ftnlen)1, &c__92); - i__3[1] = 1, a__2[1] = ch__1; - i__3[2] = 6, a__2[2] = "it tr}"; - s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); - *lnote += 7; - return 0; - } - if (comtrill_1.xnsktr[itr - 1] < .95f) { - nfmt = 2; - } else if (comtrill_1.xnsktr[itr - 1] < 9.95f) { - nfmt = 3; - } else { - nfmt = 4; - } - i__1 = *lnote; - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = *lnote + nfmt - i__1; - ici__1.iciunit = notexq + i__1; -/* Writing concatenation */ - i__3[0] = 2, a__2[0] = "(f"; - i__4 = nfmt + 48; - chax_(ch__1, (ftnlen)1, &i__4); - i__3[1] = 1, a__2[1] = ch__1; - i__3[2] = 3, a__2[2] = ".1)"; - ici__1.icifmt = (s_cat(ch__2, a__2, i__3, &c__3, (ftnlen)6), ch__2); - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&comtrill_1.xnsktr[itr - 1], (ftnlen)sizeof(real)); - e_wsfi(); - *lnote += nfmt; -/* Writing concatenation */ - i__2[0] = *lnote, a__1[0] = notexq; - i__2[1] = 1, a__1[1] = "}"; - s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); - ++(*lnote); - return 0; -} /* dotrill_ */ - -/* Subroutine */ int endslur_(logical *stemup, logical *upslur, integer * - nolev, integer *iupdn, integer *ndxslur, integer *ivoff, integer *ncm, - char *soutq, integer *lsout, logical *fontslur, ftnlen soutq_len) -{ - /* System generated locals */ - address a__1[2], a__2[4]; - integer i__1[2], i__2, i__3[4]; - char ch__1[1]; - - /* Builtin functions */ - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static logical shift; - static integer lnote; - static char noteq[8]; - extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, - ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *, - ftnlen); - static integer lnoten; - static char notexq[79]; - - -/* Only called to end slur started in dograce. */ - - shift = ! (*stemup) && ! (*upslur); - if (! shift) { - -/* No shift needed */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__1[0] = 1, a__1[0] = ch__1; - i__1[1] = 5, a__1[1] = "tslur"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - lnote = 6; - } else { - -/* Shift needed */ - -/* Writing concatenation */ - chax_(ch__1, (ftnlen)1, &c__92); - i__1[0] = 1, a__1[0] = ch__1; - i__1[1] = 2, a__1[1] = "ts"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - lnote = 3; - } -/* if (ndxslur .lt. 10) then */ -/* notexq = notexq(1:lnote)//chax(48+ndxslur) */ -/* lnote = lnote+1 */ -/* else */ -/* notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}' */ -/* lnote = lnote+4 */ -/* end if */ - -/* c Print 11-ndxslur */ -/* Print 23-ndxslur */ - -/* if (11-ndxslur .lt. 10) then */ - if (23 - *ndxslur < 10) { -/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ -/* Writing concatenation */ - i__1[0] = lnote, a__1[0] = notexq; - i__2 = 71 - *ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__1[1] = 1, a__1[1] = ch__1; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - ++lnote; - } else if (23 - *ndxslur < 20) { -/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ -/* Writing concatenation */ - i__3[0] = lnote, a__2[0] = notexq; - i__3[1] = 2, a__2[1] = "{1"; - i__2 = 61 - *ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__3[2] = 1, a__2[2] = ch__1; - i__3[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79); - lnote += 4; - } else { -/* Writing concatenation */ - i__3[0] = lnote, a__2[0] = notexq; - i__3[1] = 2, a__2[1] = "{2"; - i__2 = 51 - *ndxslur; - chax_(ch__1, (ftnlen)1, &i__2); - i__3[2] = 1, a__2[2] = ch__1; - i__3[3] = 1, a__2[3] = "}"; - s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79); - lnote += 4; - } - i__2 = *nolev + *iupdn + *ivoff; - notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); -/* Writing concatenation */ - i__1[0] = lnote, a__1[0] = notexq; - i__1[1] = lnoten, a__1[1] = noteq; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - lnote += lnoten; - if (shift) { - if (*fontslur) { -/* Writing concatenation */ - i__1[0] = lnote, a__1[0] = notexq; - i__1[1] = 5, a__1[1] = "{-.6}"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - } else { -/* Writing concatenation */ - i__1[0] = lnote, a__1[0] = notexq; - i__1[1] = 5, a__1[1] = "{-.8}"; - s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); - } - lnote += 5; - } - addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); - return 0; -} /* endslur_ */ - -/* Subroutine */ int errmsg_(char *lineq, integer *iccount, integer *ibarno, - char *msgq, ftnlen lineq_len, ftnlen msgq_len) -{ - /* System generated locals */ - address a__1[2], a__2[5], a__3[4]; - integer i__1[2], i__2, i__3, i__4[5], i__5[4]; - real r__1; - char ch__1[18], ch__2[1], ch__3[1], ch__4[7], ch__5[79]; - cilist ci__1; - olist o__1; - cllist cl__1; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, - char **, integer *, integer *, ftnlen); - integer s_wsle(cilist *), e_wsle(void), f_open(olist *), s_wsfe(cilist *), - do_fio(integer *, char *, ftnlen), e_wsfe(void), f_clos(cllist *) - ; - double r_lg10(real *); - integer i_indx(char *, char *, ftnlen, ftnlen), do_lio(integer *, integer - *, char *, ftnlen); - - /* Local variables */ - static integer i1, i10; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static char outq[78]; - static integer iposn, ndigbn, ndignl, nlinep, lenmsg; - extern /* Subroutine */ int printl_(char *, ftnlen); - static integer ibarnop; - - /* Fortran I/O blocks */ - static cilist io___481 = { 0, 6, 0, 0, 0 }; - static cilist io___484 = { 0, 19, 0, "(i6)", 0 }; - static cilist io___488 = { 0, 6, 0, "(1x,a)", 0 }; - static cilist io___489 = { 0, 15, 0, "(a)", 0 }; - static cilist io___492 = { 0, 6, 0, 0, 0 }; - static cilist io___493 = { 0, 15, 0, "(a)", 0 }; - - - if (*iccount <= 78) { - s_copy(outq, lineq, (ftnlen)78, (ftnlen)78); - iposn = *iccount; - } else { -/* Writing concatenation */ - i__1[0] = 4, a__1[0] = "... "; - i__1[1] = 74, a__1[1] = lineq + 54; - s_cat(outq, a__1, i__1, &c__2, (ftnlen)78); - iposn = *iccount - 50; - } - s_wsle(&io___481); - e_wsle(); - ibarnop = *ibarno; - if (c1omget_1.linesinpmxmod == 0 || c1omget_1.nline > - c1omget_1.line1pmxmod + c1omget_1.linesinpmxmod) { - -/* Error is in main .pmx file */ - -/* nlinep = nline-linesinpmxmod */ -/* Correct for comments not copied into buffer */ - nlinep = truelinecount_1.linewcom[c1omget_1.nline - 1] - - c1omget_1.linesinpmxmod; - } else { - -/* Error is in include file */ - - ibarnop = 0; - nlinep = c1omget_1.nline - c1omget_1.line1pmxmod + 1; - printl_("ERROR in include file named above, description given below", - (ftnlen)58); - } - o__1.oerr = 0; - o__1.ounit = 19; - o__1.ofnmlen = 11; - o__1.ofnm = "pmxaerr.dat"; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1); - s_wsfe(&io___484); - do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); - e_wsfe(); - cl__1.cerr = 0; - cl__1.cunit = 19; - cl__1.csta = 0; - f_clos(&cl__1); -/* Computing MAX */ - r__1 = ibarnop + .1f; - i__2 = 1, i__3 = (integer) (r_lg10(&r__1) + 1); - ndigbn = max(i__2,i__3); - r__1 = nlinep + .1f; - ndignl = (integer) (r_lg10(&r__1) + 1); - lenmsg = i_indx(msgq, "!", msgq_len, (ftnlen)1) - 1; - -/* Split off msgq(..) since UNIX compilers don't allow concat substring!!! */ - - ci__1.cierr = 0; - ci__1.ciunit = 6; -/* Writing concatenation */ - i__4[0] = 8, a__2[0] = "(/,a15,i"; - i__2 = ndignl + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__4[1] = 1, a__2[1] = ch__2; - i__4[2] = 5, a__2[2] = ",a6,i"; - i__3 = ndigbn + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__4[3] = 1, a__2[3] = ch__3; - i__4[4] = 3, a__2[4] = ",$)"; - ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1); - s_wsfe(&ci__1); - do_fio(&c__1, " ERROR in line ", (ftnlen)15); - do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); - do_fio(&c__1, ", bar ", (ftnlen)6); - do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer)); - e_wsfe(); - s_wsfe(&io___488); - do_fio(&c__1, msgq, lenmsg); - e_wsfe(); - ci__1.cierr = 0; - ci__1.ciunit = 15; -/* Writing concatenation */ - i__4[0] = 8, a__2[0] = "(/,a15,i"; - i__2 = ndignl + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__4[1] = 1, a__2[1] = ch__2; - i__4[2] = 5, a__2[2] = ",a6,i"; - i__3 = ndigbn + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__4[3] = 1, a__2[3] = ch__3; - i__4[4] = 3, a__2[4] = ",$)"; - ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1); - s_wsfe(&ci__1); - do_fio(&c__1, " ERROR in line ", (ftnlen)15); - do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); - do_fio(&c__1, ", bar ", (ftnlen)6); - do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer)); - e_wsfe(); - s_wsfe(&io___489); - do_fio(&c__1, msgq, lenmsg); - e_wsfe(); - i10 = iposn / 10; - i1 = iposn - i10 * 10; - ci__1.cierr = 0; - ci__1.ciunit = 6; -/* Writing concatenation */ - i__5[0] = 1, a__3[0] = "("; - i__2 = i10 + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__2; - i__3 = i1 + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__5[2] = 1, a__3[2] = ch__3; - i__5[3] = 4, a__3[3] = "x,a)"; - ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); - s_wsfe(&ci__1); - do_fio(&c__1, "v", (ftnlen)1); - e_wsfe(); - ci__1.cierr = 0; - ci__1.ciunit = 15; -/* Writing concatenation */ - i__5[0] = 1, a__3[0] = "("; - i__2 = i10 + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__2; - i__3 = i1 + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__5[2] = 1, a__3[2] = ch__3; - i__5[3] = 4, a__3[3] = "x,a)"; - ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); - s_wsfe(&ci__1); - do_fio(&c__1, "v", (ftnlen)1); - e_wsfe(); - s_wsle(&io___492); - do_lio(&c__9, &c__1, outq, (ftnlen)78); - e_wsle(); - s_wsfe(&io___493); -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = " "; - i__1[1] = 78, a__1[1] = outq; - s_cat(ch__5, a__1, i__1, &c__2, (ftnlen)79); - do_fio(&c__1, ch__5, (ftnlen)79); - e_wsfe(); - ci__1.cierr = 0; - ci__1.ciunit = 6; -/* Writing concatenation */ - i__5[0] = 1, a__3[0] = "("; - i__2 = i10 + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__2; - i__3 = i1 + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__5[2] = 1, a__3[2] = ch__3; - i__5[3] = 4, a__3[3] = "x,a)"; - ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); - s_wsfe(&ci__1); - do_fio(&c__1, "^", (ftnlen)1); - e_wsfe(); - ci__1.cierr = 0; - ci__1.ciunit = 15; -/* Writing concatenation */ - i__5[0] = 1, a__3[0] = "("; - i__2 = i10 + 48; - chax_(ch__2, (ftnlen)1, &i__2); - i__5[1] = 1, a__3[1] = ch__2; - i__3 = i1 + 48; - chax_(ch__3, (ftnlen)1, &i__3); - i__5[2] = 1, a__3[2] = ch__3; - i__5[3] = 4, a__3[3] = "x,a)"; - ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); - s_wsfe(&ci__1); - do_fio(&c__1, "^", (ftnlen)1); - e_wsfe(); - return 0; -} /* errmsg_ */ - -/* Subroutine */ int eskb4_(integer *ip, integer *ivx, integer *in, integer * - ib, real *space, real *tstart, real *fbar, integer *itrpt, real *esk) -{ - /* System generated locals */ - real r__1; - - /* Builtin functions */ - integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, - char *, ftnlen), e_wsle(void); - /* Subroutine */ int s_stop(char *, ftnlen); - - /* Local variables */ - static integer iib; - extern doublereal feon_(real *); - static integer itnd, nnsk, itprev; - - /* Fortran I/O blocks */ - static cilist io___498 = { 0, 6, 0, 0, 0 }; - - - -/* Get elemskips to previous note. Called only for graces, no xtups involved. */ - - /* Parameter adjustments */ - --tstart; - --space; - - /* Function Body */ - itnd = i_nint(&all_1.to[*in - 1]); - if (*ip == 1 || itnd == *itrpt) { - -/* Start of bar or after rpt. */ - - *esk = *fbar; - return 0; - } else { - *esk = 0.f; - itprev = itnd - all_1.nodur[*ivx + (*ip - 1) * 24 - 25]; - for (iib = *ib; iib >= 1; --iib) { - if (tstart[iib] < itprev + comtol_1.tol) { - -/* This is the block */ - - r__1 = (real) (itnd - itprev) / space[iib]; - nnsk = i_nint(&r__1); - *esk += nnsk * feon_(&space[iib]); - return 0; - } else { - r__1 = (itnd - tstart[iib]) / space[iib]; - nnsk = i_nint(&r__1); - *esk += nnsk * feon_(&space[iib]); - itnd = i_nint(&tstart[iib]); - } -/* L1: */ - } - } - s_wsle(&io___498); - do_lio(&c__9, &c__1, "Problem in eskb4. Send files to Dr. Don", (ftnlen) - 40); - e_wsle(); - s_stop("", (ftnlen)0); - return 0; -} /* eskb4_ */ - -doublereal f1eon_(real *time) -{ - /* System generated locals */ - real ret_val; - - /* Builtin functions */ - double sqrt(doublereal); - - ret_val = sqrt(*time / 2); - return ret_val; -} /* f1eon_ */ - -doublereal feon_(real *time) -{ - /* System generated locals */ - real ret_val; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal), pow_dd(doublereal *, doublereal *); - - d__1 = (doublereal) sqrt(*time / 2); - d__2 = (doublereal) (1.f - comeon_1.eonk); - ret_val = pow_dd(&d__1, &d__2) * comeon_1.ewmxk; - return ret_val; -} /* feon_ */ - -/* Subroutine */ int findbeam_(integer *ibmrep, integer *numbms, integer * - mapfb) -{ - /* Initialized data */ - - static integer nip1[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; - static integer nip2[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; - static integer nummask[3] = { 29,49,12 }; - static integer mask[147] /* was [49][3] */ = { 65535,4095,65520,255, - 65280,63,252,16128,64512,15,240,3840,61440,7,14,112,224,1792,3584, - 28672,57344,3,12,48,192,768,3072,12288,49152,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,16777215,65535,16776960,4095,65520,1048320, - 16773120,255,65280,16711680,63,252,16128,64512,4128768,16515072, - 15,60,240,3840,15360,61440,983040,3932160,15728640,7,14,112,224, - 1792,3584,28672,57344,458752,917504,7340032,14680064,3,12,48,192, - 768,3072,12288,49152,196608,786432,3145728,12582912,4095,255,4080, - 15,240,3840,3,12,48,192,768,3072,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; - static logical eqonly[147] /* was [49][3] */ = { TRUE_,TRUE_,TRUE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, - FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_ }; - - /* System generated locals */ - integer i__1, i__2, i__3, i__4; - real r__1, r__2; - - /* Builtin functions */ - integer lbit_shift(integer, integer), s_wsle(cilist *), do_lio(integer *, - integer *, char *, ftnlen), e_wsle(void); - double r_mod(real *, real *); - - /* Local variables */ - static integer ib, ip, ir, it, is, ib1, ib2, ir1, is1, is2, it2, iip, ipr[ - 248], itr[248], mape, mapm, irep, maps, nreal, itend, itoff, - maskm, nodue[248], itseg, mtemp; - static logical short__[248]; - static integer itnow, ithalf, numnew; - extern /* Subroutine */ int logbeam_(integer *, integer *, integer *); - static integer masknow; - - /* Fortran I/O blocks */ - static cilist io___532 = { 0, 6, 0, 0, 0 }; - - - -/* Called once per voice per bar, after setting forced beams. */ - -/* integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16), */ -/* * itr(48),nodue(48) */ -/* logical short(48),eqonly */ - /* Parameter adjustments */ - --mapfb; - --numbms; - - /* Function Body */ - ip = 0; - nreal = 0; - itnow = 0; -L1: - ++ip; - if (ip > all_1.nn[commvl_1.ivx - 1]) { - goto L9; - } -L11: - if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) { - -/* Ignore all xtup notes except the last, the one with nodur > 0 . */ -/* Xtups are irrelevant here since they are already all in forced beams. */ -/* Will update itnow by nodur at the END of this loop */ - - ++ip; - goto L11; - } - ++nreal; - nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; - short__[nreal - 1] = nodue[nreal - 1] < 16 && ! bit_test(all_1.irest[ - commvl_1.ivx + ip * 24 - 25],0) && ! bit_test(all_1.islur[ - commvl_1.ivx + ip * 24 - 25],18); - -/* Rule out notes that have 'alone'-flag set */ - - ipr[nreal - 1] = ip; - itr[nreal - 1] = itnow; - if (nodue[nreal - 1] == 1) { - -/* 64th gap */ - - if (itnow % 2 == 0) { - -/* Start of 32nd gap, lump with following note */ - - ++ip; - nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25] + 1; - itnow += nodue[nreal - 1]; - } else { - -/* End of 32nd gap, lump with preceeding note */ - - --nreal; - ++nodue[nreal - 1]; - ++itnow; - } - } else { - itnow += all_1.nodur[commvl_1.ivx + ip * 24 - 25]; - } - goto L1; -L9: - ir1 = 1; - itseg = all_1.lenbar / *ibmrep; - i__1 = *ibmrep; - for (irep = 1; irep <= i__1; ++irep) { - -/* Set bitmaps for all shorts neighbored by a short. Each bit represents a */ -/* span of 32nd note. maps, mapm, mape record start, full duration, and end */ -/* of consecutive span of beamable (<1/4) notes. */ - - maps = 0; - mapm = 0; - mape = 0; - itend = itseg * irep; - itoff = itend - itseg; - i__2 = nreal; - for (ir = ir1; ir <= i__2; ++ir) { - it2 = itr[ir - 1] + nodue[ir - 1] - 2; - if (it2 >= itend) { - ir1 = ir; - goto L14; - } -/* if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal */ -/* Computing MAX */ - i__3 = ir - 1; - if (short__[ir - 1] && (ir > 1 && short__[max(i__3,1) - 1] || ir < - nreal && short__[ir])) { - ib1 = (itr[ir - 1] - itoff) / 2; - ib2 = (it2 - itoff) / 2; - if (max(ib1,ib2) > 47 || ir > 48 || min(ib1,ib2) < 0) { - return 0; - } - -/* Must have an odd number obe beats in a long bar. Auto-beam won't work */ - - nip1[ib1] = ipr[ir - 1]; - nip2[ib2] = ipr[ir - 1]; - -/* nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip */ - - maps = bit_set(maps,ib1); - mape = bit_set(mape,ib2); - i__3 = ib2; - for (ib = ib1; ib <= i__3; ++ib) { - mapm = bit_set(mapm,ib); -/* L3: */ - } - } -/* L2: */ - } -L14: - if (mapm == 0) { - goto L13; - } - -/* Zero out bits from forced beams */ - - maps &= ~ mapfb[irep]; - mapm &= ~ mapfb[irep]; - mape &= ~ mapfb[irep]; - -/* Compare map with template. */ - - i__2 = nummask[combeam_1.ibmtyp - 1]; - for (it = 1; it <= i__2; ++it) { - masknow = mask[it + combeam_1.ibmtyp * 49 - 50]; - if ((masknow & mapm) == masknow) { - -/* Find least significant bit in the mask to check start time */ - - mtemp = masknow; - maskm = masknow; - for (is1 = 0; is1 <= 47; ++is1) { - if ((1 & mtemp) == 1) { - goto L6; - } - mtemp = lbit_shift(mtemp, (ftnlen)-1); -/* L5: */ - } -L6: - if ((lbit_shift((ftnlen)1, is1) & maps) == 0) { - goto L4; - } - -/* is1 is the bit where the beam starts. Continue shifting to */ -/* find most significant bit in the mask to check ending time */ - - for (is2 = is1; is2 <= 47; ++is2) { - mtemp = lbit_shift(mtemp, (ftnlen)-1); - if ((1 & ~ mtemp) == 1) { - goto L8; - } -/* L7: */ - } -L8: - -/* is2 is now the bit on which the beam ends. */ - - if ((lbit_shift((ftnlen)1, is2) & mape) == 0) { - goto L4; - } - -/* Did we pick out a single note from the middle of a longer sequence? */ - - if (nip1[is1] == nip2[is2]) { - goto L4; - } - -/* We almost have a beam. Check equality of notes if needed. */ - - if (eqonly[it + combeam_1.ibmtyp * 49 - 50]) { - i__3 = nip2[is2]; - for (ip = nip1[is1]; ip <= i__3; ++ip) { - if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] != 8) { - -/* There is a non-1/8th note in this beam. Exit if not 2 quarters */ - - if (is2 - is1 != 15) { - goto L4; - } - -/* Beam is 2 quarters long. Check if can split in half. */ - - ithalf = 0; - i__4 = nip2[is2]; - for (iip = nip1[is1]; iip <= i__4; ++iip) { - ithalf += all_1.nodur[commvl_1.ivx + iip * 24 - - 25]; - if (ithalf > 16) { - goto L4; - } - if (ithalf == 16) { - goto L21; - } -/* L20: */ - } - s_wsle(&io___532); - do_lio(&c__9, &c__1, "Problem in findbeam, pleas" - "e call Dr. Don", (ftnlen)40); - e_wsle(); - goto L4; -L21: - -/* Otherwise, split in half by keeping only the first half. Other half will */ -/* be picked up later, assuming masks are listed longest first. */ - - is2 = is1 + 7; - -/* Reset maskm (since only used part of mask), used later to zero out */ -/* bits that contain beams */ - - maskm = 0; - i__4 = is2; - for (is = is1; is <= i__4; ++is) { - maskm = bit_set(maskm,is); -/* L15: */ - } - goto L16; - } -/* L10: */ - } - } -L16: - -/* This is a beam. If last "effective" ends on odd 64th, add 1 more */ - -/* if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) */ -/* * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then */ - r__2 = all_1.to[comipl2_1.ipl2[commvl_1.ivx + nip2[is2] * 24 - - 25] - 1] + all_1.nodur[commvl_1.ivx + nip2[is2] * - 24 - 25] + comtol_1.tol * .5f; - if ((r__1 = r_mod(&r__2, &c_b1633), dabs(r__1)) > - comtol_1.tol) { - ++nip2[is2]; - } - ++numbms[commvl_1.ivx]; - numnew = numbms[commvl_1.ivx]; - logbeam_(&numnew, &nip1[is1], &nip2[is2]); - -/* Zero out the appropriate bits so these notes don't get used again */ - - mapm &= ~ maskm; - if (mapm == 0) { - goto L13; - } - maps &= ~ maskm; - mape &= ~ maskm; - } -L4: - ; - } -L13: - ; - } - return 0; -} /* findbeam_ */ - -/* Subroutine */ int findeonk_(integer *nptr1, integer *nptr2, real *wovera, - real *xelsk, real *dtmin, real *dtmax, real *eonk0) -{ - /* System generated locals */ - integer i__1; - real r__1; - doublereal d__1, d__2; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *), sqrt(doublereal), log( - doublereal); - - /* Local variables */ - static real f, fp; - extern doublereal feon_(real *); - static real targ, esum; - static integer iptr; - extern doublereal f1eon_(real *); - static real desum, dsoln; - static integer niter; - static real detarg; - extern /* Subroutine */ int printl_(char *, ftnlen); - - -/* Compute an exponent eonk for use in the "flattened" formula for elemskips */ -/* vs time. We must solve the eqution f = 0. Initial quess is eonk0. */ - - comeon_1.eonk = *eonk0; - niter = 0; -L1: - d__1 = (doublereal) f1eon_(dtmax); - d__2 = (doublereal) comeon_1.eonk; - comeon_1.ewmxk = pow_dd(&d__1, &d__2); - ++niter; - esum = 0.f; - desum = 0.f; - i__1 = *nptr2; - for (iptr = *nptr1; iptr <= i__1; ++iptr) { - targ = c1omnotes_1.durb[iptr - 1] / c1omnotes_1.sqzb[iptr - 1]; - esum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] * - feon_(&targ); - d__1 = (doublereal) (*dtmax / targ); - d__2 = (doublereal) comeon_1.eonk; - detarg = sqrt(targ / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / targ); - desum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] * - detarg; -/* L2: */ - } - f = *wovera * feon_(dtmin) - *xelsk - esum; - d__1 = (doublereal) (*dtmax / *dtmin); - d__2 = (doublereal) comeon_1.eonk; - fp = *wovera * sqrt(*dtmin / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / * - dtmin) - desum; - if (dabs(fp) < comtol_1.tol || (r__1 = comeon_1.eonk - .5f, dabs(r__1)) > - .5f || niter > 100) { - printl_("Error in findeonk. Please send source to Dr. Don", (ftnlen) - 49); - comeon_1.eonk = 0.f; - comeon_1.ewmxk = 1.f; - return 0; - } - dsoln = -f / fp; - if (dabs(dsoln) < comtol_1.tol * .1f) { - return 0; - } - -/* Not converged yet, try again */ - - comeon_1.eonk += dsoln; - goto L1; -} /* findeonk_ */ - -doublereal fnote_(integer *nodur, integer *ivx, integer *ip, integer *nacc) -{ - /* System generated locals */ - real ret_val; - - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - - /* Local variables */ - static integer iip, ip1m1; - extern /* Subroutine */ int stop1_(void); - static integer ndoub, ipback; - extern /* Subroutine */ int printl_(char *, ftnlen); - - /* Fortran I/O blocks */ - static cilist io___548 = { 0, 6, 0, 0, 0 }; - - - -/* This return the real duration of a note */ - - /* Parameter adjustments */ - nacc -= 25; - nodur -= 25; - - /* Function Body */ - ipback = *ip; - if (nodur[*ivx + *ip * 24] > 0) { - if (*ip > 1) { - -/* Check if this is last note of xtup */ - - if (nodur[*ivx + (*ip - 1) * 24] == 0) { - ipback = *ip - 1; - goto L2; - } - } - ret_val = (real) nodur[*ivx + *ip * 24]; - return ret_val; - } -L2: - -/* Count back to prior non zero note. Start at ip to avoid neg index if ip=1. */ -/* Count how many doubled xtups notes there are from ip-1 to first note. */ - - ndoub = 0; - for (ip1m1 = ipback; ip1m1 >= 1; --ip1m1) { - if (nodur[*ivx + ip1m1 * 24] > 0) { - goto L4; - } - if (ip1m1 < *ip && bit_test(nacc[*ivx + ip1m1 * 24],18)) { - ++ndoub; - } -/* L1: */ - } -L4: - -/* count forward to next non-0 nodur. Start at ip in case last note of xtup. */ - - for (iip = *ip; iip <= 200; ++iip) { - -/* Count doubled xtup notes from ip to end. */ - - if (bit_test(nacc[*ivx + iip * 24],18)) { - ++ndoub; - } - if (nodur[*ivx + iip * 24] > 0) { -/* fnote = nodur(ivx,iip)/float(iip-ip1m1) */ - ret_val = nodur[*ivx + iip * 24] / (real) (iip - ip1m1 + ndoub); - if (bit_test(nacc[*ivx + *ip * 24],18)) { - ret_val *= 2; - } else if (bit_test(nacc[*ivx + *ip * 24],27)) { - ret_val *= 1.5f; - } else if (*ip > 1) { - if (bit_test(nacc[*ivx + (*ip - 1) * 24],27)) { - ret_val *= .5f; - } - } - return ret_val; - } -/* L3: */ - } - s_wsle(&io___548); - do_lio(&c__9, &c__1, " ", (ftnlen)1); - e_wsle(); - printl_("Probable misplaced barline or incorrect meter, stopping", ( - ftnlen)55); -/* call printl('Program error in fnote, send source to Dr. Don') */ - stop1_(); - return ret_val; -} /* fnote_ */ - -/* Subroutine */ int g1etchar_(char *lineq, integer *iccount, char *charq, - ftnlen lineq_len, ftnlen charq_len) -{ - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - static integer ndxm; - extern /* Subroutine */ int read10_(char *, logical *, ftnlen), m1rec1_( - char *, integer *, integer *, integer *, integer *, integer *, - ftnlen); - static integer nbars, ibaroff, ibarcnt; - - -/* Gets the next character out of lineq*128. If pointer iccount=128 on entry, */ -/* then reads in a new line. Resets iccount. Ends program if no more input. */ - - if (*iccount == 128) { - read10_(lineq, &c1omget_1.lastchar, (ftnlen)128); - if (c1omget_1.lastchar) { - return 0; - } - if (! commac_1.endmac) { - *iccount = 0; - if (! commac_1.mplay) { - ++c1omget_1.nline; - } - } else { - commac_1.endmac = FALSE_; - *iccount = commac_1.icchold; - s_copy(lineq, commac_1.lnholdq, (ftnlen)128, (ftnlen)128); - } - if (commac_1.mrecord) { - m1rec1_(lineq, iccount, &ibarcnt, &ibaroff, &nbars, &ndxm, ( - ftnlen)128); - } - } - ++(*iccount); - *(unsigned char *)charq = *(unsigned char *)&lineq[*iccount - 1]; - return 0; -} /* g1etchar_ */ - -/* Subroutine */ int g1etnote_(logical *loop, integer *ifig, logical * - optimize, logical *fulltrans) -{ - /* Initialized data */ - - static char literq[51*3] = "Literal TeX string cannot start with 4 backs" - "lashes!" "TeX string must have <129 char, end with backslash!" - "Type 2 or 3 TeX string can only start in column 1! "; - - /* System generated locals */ - address a__1[3], a__2[2], a__3[4]; - integer i__1, i__2[3], i__3[2], i__4, i__5, i__6, i__7, i__8[4]; - real r__1; - char ch__1[42], ch__2[1], ch__3[55], ch__4[54], ch__5[46]; - icilist ici__1; - - /* Builtin functions */ - integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle( - void), do_lio(integer *, integer *, char *, ftnlen), s_wsfe( - cilist *); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - integer do_fio(integer *, char *, ftnlen), e_wsfe(void), s_cmp(char *, - char *, ftnlen, ftnlen), i_nint(real *); - double log(doublereal); - integer pow_ii(integer *, integer *), s_rsfe(cilist *), e_rsfe(void), - s_rsfi(icilist *), e_rsfi(void); - - /* Local variables */ - extern integer i1fnodur_(integer *, char *, ftnlen); - extern /* Subroutine */ int checkdyn_(char *, integer *, integer *, - ftnlen); - static integer idotform, ndxquote, i__, j; - extern /* Subroutine */ int readmeter_(char *, integer *, integer *, - integer *, ftnlen), getpmxmod_(logical *, char *, ftnlen); - static integer ic, igr, ipm; - static real dum; - static integer ngr, iiv, nbb4, num1, num2; - extern /* Character */ VOID chax_(char *, ftnlen, integer *); - static logical cdot; - static real fnum; - static char dumq[1], dotq[1], durq[1]; - static integer itup; - static real snum; - static integer ntup; - extern /* Subroutine */ int g1etx_(char *, integer *, logical *, logical * - , integer *, real *, real *, ftnlen), stop1_(void), read10_(char * - , logical *, ftnlen); - static real dimen; - static char charq[1]; - static integer indxb; - static char lineq[128]; - static integer icsav, ndoub, iorig, iinow, iposn, ninow; - extern /* Subroutine */ int getitransinfo_(logical *, integer *, char *, - integer *, integer *, integer *, integer *, integer *, ftnlen); - static integer icclhw; - static char charlq[1]; - extern /* Subroutine */ int setmac_(char *, integer *, integer *, integer - *, integer *, char *, char *, integer *, integer *, ftnlen, - ftnlen, ftnlen), chklit_(char *, integer *, integer *, ftnlen); - static logical fulbrp; - extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *, - ftnlen, ftnlen); - static integer literr, mtrdnp; - static real sysflb; - static integer numint, mtrnmp, numnum; - static logical ztrans; - static real fnsyst; - static integer lenbeat; - extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen, - ftnlen), getmidi_(integer *, char *, integer *, integer *, - integer *, integer *, integer *, integer *, logical *, ftnlen), - readnum_(char *, integer *, char *, real *, ftnlen, ftnlen); - static integer mtrdenl, lenmult, numshft; - static logical plusmin; - static real tintstf; - extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen, - ftnlen); - static integer lvoltxt; - - /* Fortran I/O blocks */ - static cilist io___558 = { 0, 6, 0, 0, 0 }; - static cilist io___559 = { 0, 6, 0, 0, 0 }; - static cilist io___560 = { 0, 6, 0, 0, 0 }; - static cilist io___561 = { 0, 6, 0, 0, 0 }; - static cilist io___562 = { 0, 15, 0, "(/a)", 0 }; - static cilist io___563 = { 0, 15, 0, "(a11,2x,i3)", 0 }; - static cilist io___564 = { 0, 15, 0, 0, 0 }; - static cilist io___565 = { 0, 6, 0, 0, 0 }; - static cilist io___573 = { 0, 6, 0, 0, 0 }; - static cilist io___574 = { 0, 6, 0, 0, 0 }; - static cilist io___575 = { 0, 6, 0, 0, 0 }; - static cilist io___580 = { 0, 6, 0, 0, 0 }; - static cilist io___581 = { 0, 6, 0, 0, 0 }; - static cilist io___582 = { 0, 6, 0, 0, 0 }; - static cilist io___595 = { 0, 6, 0, 0, 0 }; - static cilist io___598 = { 0, 6, 0, 0, 0 }; - static cilist io___599 = { 0, 6, 0, 0, 0 }; - static cilist io___600 = { 0, 6, 0, 0, 0 }; - static cilist io___603 = { 0, 6, 0, 0, 0 }; - static cilist io___609 = { 0, 6, 0, 0, 0 }; - static cilist io___610 = { 0, 6, 0, 0, 0 }; - static cilist io___611 = { 0, 15, 0, "(/,a)", 0 }; - static cilist io___612 = { 0, 6, 0, 0, 0 }; - static cilist io___613 = { 0, 6, 0, 0, 0 }; - static cilist io___614 = { 0, 15, 0, "(a)", 0 }; - static cilist io___615 = { 0, 15, 0, "(a)", 0 }; - static cilist io___623 = { 0, 6, 0, 0, 0 }; - static cilist io___624 = { 0, 6, 0, 0, 0 }; - static cilist io___625 = { 0, 6, 0, 0, 0 }; - static cilist io___626 = { 0, 6, 0, "(1x,a21,i3,a23)", 0 }; - static cilist io___630 = { 0, 6, 0, 0, 0 }; - static cilist io___631 = { 0, 6, 0, 0, 0 }; - static cilist io___632 = { 0, 5, 0, "(a)", 0 }; - static cilist io___636 = { 0, 6, 0, 0, 0 }; - static cilist io___637 = { 0, 6, 0, 0, 0 }; - - - cdot = FALSE_; -L1: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)charq != ' ') { - *(unsigned char *)charlq = *(unsigned char *)charq; - } - if (c1omget_1.lastchar) { - if (i_indx("/%", charlq, (ftnlen)2, (ftnlen)1) == 0) { - s_wsle(&io___558); - e_wsle(); - s_wsle(&io___559); - do_lio(&c__9, &c__1, "WARNING:", (ftnlen)8); - e_wsle(); - s_wsle(&io___560); - do_lio(&c__9, &c__1, "Last non-blank character is \"", (ftnlen)29) - ; - do_lio(&c__9, &c__1, charlq, (ftnlen)1); - do_lio(&c__9, &c__1, "\", not \"/,%\"", (ftnlen)12); - e_wsle(); - s_wsle(&io___561); - do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11); - i__1 = *(unsigned char *)charlq; - do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer)); - e_wsle(); - s_wsfe(&io___562); -/* Writing concatenation */ - i__2[0] = 29, a__1[0] = "Last non-blank character is \""; - i__2[1] = 1, a__1[1] = charlq; - i__2[2] = 12, a__1[2] = "\", not \"/,%\""; - s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)42); - do_fio(&c__1, ch__1, (ftnlen)42); - e_wsfe(); - s_wsfe(&io___563); - do_fio(&c__1, "ASCII code:", (ftnlen)11); - i__1 = *(unsigned char *)charlq; - do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); - e_wsfe(); - -/* Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. */ - - --inbuff_1.ilbuf; - inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) (inbuff_1.lbuf[ - inbuff_1.ilbuf - 1] + 2); -/* Writing concatenation */ - i__3[0] = inbuff_1.ipbuf, a__2[0] = inbuff_1.bufq; - i__3[1] = 2, a__2[1] = " /"; - s_cat(inbuff_1.bufq, a__2, i__3, &c__2, (ftnlen)65536); - s_wsle(&io___564); - do_lio(&c__9, &c__1, "appending /", (ftnlen)18); - e_wsle(); - s_wsle(&io___565); - do_lio(&c__9, &c__1, "appending /", (ftnlen)18); - e_wsle(); -/* Writing concatenation */ - i__3[0] = a1ll_2.iccount, a__2[0] = lineq; - i__3[1] = 2, a__2[1] = " /"; - s_cat(lineq, a__2, i__3, &c__2, (ftnlen)128); - c1omget_1.lastchar = FALSE_; - goto L1; - } - return 0; - } - if (*(unsigned char *)charq == ' ') { - goto L1; - } else if (*(unsigned char *)charq == '%' && a1ll_2.iccount == 1) { - a1ll_2.iccount = 128; - goto L1; - -/* Replacement 1/22/12 since gfortran 4.7 with -O was choking here! */ - -/* else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. */ - } else if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) > 0 || *( - unsigned char *)charq == 'r') { - -/* This is a note/rest. gotclef is only used for checking for clef before "/" */ - - if (cdot) { - goto L28; - } - if (c1omnotes_1.gotclef) { - c1omnotes_1.gotclef = FALSE_; - } - idotform = 0; - numnum = 0; - plusmin = FALSE_; -L28: - ++a1ll_2.nnl[c1ommvl_1.ivx - 1]; - if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 200) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, ">200 notes in line of mu" - "sic. Use smaller blocks!", (ftnlen)128, (ftnlen)48); - stop1_(); - } - *(unsigned char *)dotq = 'x'; - -/* Check if this is 'r ' and previous note was full-bar-pause */ - - i__1 = a1ll_2.iccount; -/* Computing MAX */ - i__4 = 1, i__5 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1; -/* Computing MAX */ - i__6 = 1, i__7 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1; - fulbrp = *(unsigned char *)charq == 'r' && s_cmp(lineq + i__1, " ", - a1ll_2.iccount + 1 - i__1, (ftnlen)1) == 0 && a1ll_2.nnl[ - c1ommvl_1.ivx - 1] > 1 && a1ll_2.rest[c1ommvl_1.ivx + max( - i__4,i__5) * 24 - 25] && a1ll_2.nodur[c1ommvl_1.ivx + max( - i__6,i__7) * 24 - 25] == a1ll_2.lenbar; -L2: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - ic = *(unsigned char *)durq; - if (ic <= 57 && ic >= 48) { - -/* Digit */ - - if (numnum == 0) { - c1omnotes_1.nnodur = ic - 48; - numnum = 1; - goto L2; - } else if (numnum == 1) { - if (*(unsigned char *)charq == 'r') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only one digit a" - "llowed after rest symbol \"r\"!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - numnum = 2; - if (plusmin) { - s_wsle(&io___573); - e_wsle(); - s_wsle(&io___574); - do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen) - 25); - e_wsle(); - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1" - ".2, +/- was ignored if octave was!", (ftnlen)128, - (ftnlen)50); - s_wsle(&io___575); - do_lio(&c__9, &c__1, "explicitly specified. May need to" - " edit old editions", (ftnlen)52); - e_wsle(); - } - goto L2; - } else { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, ">2 digits in note sy" - "mbol!", (ftnlen)128, (ftnlen)25); - stop1_(); - } - } else if (*(unsigned char *)durq == 'd') { - *(unsigned char *)dotq = *(unsigned char *)durq; - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "d", a1ll_2.iccount + 1 - i__1, (ftnlen)1) - == 0) { - c1omnotes_1.iddot = 1; - ++a1ll_2.iccount; - -/* Since we flow out, double dots won't work with other dot options */ - - } - i__1 = a1ll_2.iccount; - if (i_indx("+-", lineq + i__1, (ftnlen)2, a1ll_2.iccount + 1 - - i__1) > 0) { - -/* move a dot, provided a number follows. */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) == 0) - { - -/* Backup, exit the loop normally */ - - a1ll_2.iccount += -2; - goto L2; - } - readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Vertical shift also */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) == - 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected num" - "ber after 2nd +/- (shift dot)!", (ftnlen)128, - (ftnlen)42); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, - (ftnlen)1); - } - --a1ll_2.iccount; - } - goto L2; - } else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Accidental shift */ - -/* if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then */ - i__1 = a1ll_2.iccount - 2; - if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 - - i__1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Expected \"f\", \"s\", \"n\" o" - "r \"A\" before \"<\" or \">\"!", (ftnlen)128, (ftnlen) - 48); -/* * 'Expected "f", "s", or "n" before "<" or ">"!') */ - stop1_(); - } - ipm = 1; - if (*(unsigned char *)durq == '<') { - ipm = -1; - } - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("123456789.0", durq, (ftnlen)11, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected number afte" - "r (accidental shift)!", (ftnlen)128, (ftnlen)45); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - fnum = ipm * fnum; - if (fnum < -5.35f || fnum > 1.f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Horizontal accidental shift mu" - "st be >-5.35 and <1.0!", (ftnlen)128, (ftnlen)52); - stop1_(); - } - --a1ll_2.iccount; - goto L2; - } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - if (*(unsigned char *)charq != 'r') { - i__1 = a1ll_2.iccount - 2; - if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - - 1 - i__1) > 0) { - ipm = 1; - if (*(unsigned char *)durq == '-') { - ipm = -1; - } - i__1 = a1ll_2.iccount; - if (i_indx("0123456789", lineq + i__1, (ftnlen)10, - a1ll_2.iccount + 1 - i__1) > 0) { - -/* This may be start of accidental shift, but may be octave jump; then duration */ - - icsav = a1ll_2.iccount; - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* This is an accid shift since there's a 2nd consecutive signed number. */ -/* Check size of 1st number. */ - - if (fnum > 30.5f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__1, &i__4, "Vertical accid" - "ental shift must be less than 31!", ( - ftnlen)128, (ftnlen)47); - stop1_(); - } - ipm = 1; - if (*(unsigned char *)durq == '-') { - ipm = -1; - } - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen) - 128, (ftnlen)1); - if (i_indx("1234567890.", durq, (ftnlen)11, ( - ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expe" - "cted 2nd number of accidental shift)!" - , (ftnlen)128, (ftnlen)41); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( - ftnlen)128, (ftnlen)1); - fnum = ipm * fnum; - if (fnum < -5.35f || fnum > 1.f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__1, &i__4, "Horiz. acciden" - "tal shift must be >-5.35 and <1.0!", ( - ftnlen)128, (ftnlen)48); - stop1_(); - } - --a1ll_2.iccount; - goto L2; - } else { - -/* Not accid shift, reset, then flow out */ - - a1ll_2.iccount = icsav; - } - } - } - plusmin = TRUE_; - if (numnum == 2) { - s_wsle(&io___580); - e_wsle(); - s_wsle(&io___581); - do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen) - 25); - e_wsle(); - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1" - ".2, +/- was ignored if octave was!", (ftnlen)128, - (ftnlen)50); - s_wsle(&io___582); - do_lio(&c__9, &c__1, "explicitly specified. May need to" - " edit old editions", (ftnlen)52); - e_wsle(); - } - goto L2; - -/* It's a rest containing +|- . Must refer to a vertical shift. Read past. */ - - } else { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - goto L2; - } -/* else if (index('ulare',durq) .gt. 0) then */ - } else if (i_indx("ularec", durq, (ftnlen)6, (ftnlen)1) > 0) { - goto L2; - } else if (*(unsigned char *)durq == 'S') { - -/* Stemlength change */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx(".0123456789:", durq, (ftnlen)12, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must be a numb" - "er or colon here!", (ftnlen)128, (ftnlen)37); - stop1_(); - } - if (*(unsigned char *)durq == ':') { - if (! comkeys_1.stickys) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned off stick" - "y stemshrinks without turning on!", (ftnlen)128, ( - ftnlen)49); - stop1_(); - } - comkeys_1.stickys = FALSE_; - goto L2; - } - readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, (ftnlen) - 1); - if (dum < .5f || dum > 4.f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Stemlength shortening must be " - "from .5 to 4!", (ftnlen)128, (ftnlen)43); - stop1_(); - } - if (*(unsigned char *)durq != ':') { - --a1ll_2.iccount; - } else { - if (comkeys_1.stickys) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on sticky" - " stemshrinks when already on!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - comkeys_1.stickys = TRUE_; - } - goto L2; - } else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) { - -/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */ -/* MUST come right after "f,s,n" */ - - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1) - == 0) { - ++a1ll_2.iccount; - } - goto L2; - } else if (*(unsigned char *)durq == 'p') { - fulbrp = *(unsigned char *)charq == 'r'; - if (! fulbrp) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "The option \"p\" onl" - "y works with \"r\" (rest)!", (ftnlen)128, (ftnlen)42); - stop1_(); - } - goto L2; - } else if (*(unsigned char *)durq == 'b') { - if (*(unsigned char *)charq != 'r') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"b\"; I" - " expected \"rb\"!", (ftnlen)128, (ftnlen)33); - stop1_(); - } else if (numnum == 2) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"r\" &" - " \"b\" with two numbers!", (ftnlen)128, (ftnlen)39); - } - goto L2; - } else if (*(unsigned char *)durq == 'x') { - -/* Xtuplet. Count number of doubled notes (for unequal xtups) */ - - if (bit_test(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[ - c1ommvl_1.ivx - 1] * 24 - 25],18)) { - ndoub = 1; - } else { - ndoub = 0; - } - -/* Will set all durations to 0 except last one. */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "First char after \"" - "x\" in xtuplet must be \"1\"-\"9\"!", (ftnlen)128, ( - ftnlen)48); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (fnum > 99.f) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Xtuplet cannot have " - "more than 99 notes!", (ftnlen)128, (ftnlen)39); - stop1_(); - } else if (i_indx(" DFnd", durq, (ftnlen)5, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only legal character" - "s here are \" \",\"D\",\"F\",\"n\"!", (ftnlen)128, ( - ftnlen)47); - stop1_(); - } - -/* End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. */ - - if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Double xtup note to make an un= xtup. Here, number already set, but may also */ -/* have used this before number was set. */ - - c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + - a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],18); - ndoub = 1; - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - } else if (*(unsigned char *)durq == 'd') { - c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + - a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],27); - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - } - if (*(unsigned char *)durq == 'n') { - -/* Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. */ - - numshft = 0; -L30: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)durq == 'f') { - goto L30; - } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - ++numshft; - if (numshft == 3) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only 2 shift" - "s are allowed after \"n\" in xtup!", (ftnlen) - 128, (ftnlen)44); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == - 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact" - "er should be a digit or \".\"!", (ftnlen)128, - (ftnlen)40); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, - (ftnlen)1); - --a1ll_2.iccount; - if (numshft == 1 && snum > 15.1f || numshft == 2 && snum - > 1.51f) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Shift number" - " after \"n\" in xtup is out of range!", ( - ftnlen)128, (ftnlen)47); - stop1_(); - } - goto L30; - } else if (*(unsigned char *)durq == 's') { - -/* Slope alteration for bracket */ - - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "For slope ad" - "justment, this character must be \"+\" or \"-" - "\"!", (ftnlen)128, (ftnlen)56); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) - { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact" - "er should be a digit!", (ftnlen)128, (ftnlen) - 33); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, - (ftnlen)1); - --a1ll_2.iccount; - if (i_nint(&snum) > 15) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slope adjust" - "ment cannot exceed 15!", (ftnlen)128, (ftnlen) - 34); - stop1_(); - } - goto L30; - } else if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) > - 0) { - -/* Unsigned integer => alternate printed number */ - - readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, - (ftnlen)1); - if (snum > 15.1f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Alternate xtup number " - "after \"n\" must be <16!", (ftnlen)128, ( - ftnlen)44); - stop1_(); - } - --a1ll_2.iccount; - goto L30; - } else if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r after \"n\" in xtup!", (ftnlen)128, (ftnlen)36); - stop1_(); - } - } - ntup = i_nint(&fnum); - i__1 = ntup; - for (itup = 2; itup <= i__1; ++itup) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = 0; - ++a1ll_2.nnl[c1ommvl_1.ivx - 1]; -L110: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)durq == ' ') { - goto L110; - } else if (*(unsigned char *)durq == 'o') { - -/* Ornament in xtup. "o" symbol must come AFTER the affected note */ - - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("(stmx+Tup._)e:>^bc", dumq, (ftnlen)18, ( - ftnlen)1) == 0) { - if (i_indx("fg", dumq, (ftnlen)2, (ftnlen)1) > 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Fermata " - "or segno not allowed in xtuplet!", ( - ftnlen)128, (ftnlen)40); - } else { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal " - "ornament!", (ftnlen)128, (ftnlen)17); - } - stop1_(); - } - if (*(unsigned char *)dumq == 'T') { - -/* Trill. may be followed by 't' and/or number. read 'til blank */ - -L29: - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)dumq != ' ') { - goto L29; - } - } else if (*(unsigned char *)dumq == 'e') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal " - "character after \"e\" in edit. accid. sy" - "mbol!", (ftnlen)128, (ftnlen)51); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)dumq == '?') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen) - 128, (ftnlen)1); - } - } else if (*(unsigned char *)dumq == ':') { - i__4 = a1ll_2.iccount; - if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 - - i__4, (ftnlen)1) != 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu" - "st be followed by blank in \"o: \"!", ( - ftnlen)128, (ftnlen)39); - stop1_(); - } else if (! comkeys_1.ornrpt) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &i__4, &i__5, "Turned off repeate" - "d ornaments before they were on!", ( - ftnlen)128, (ftnlen)50); - stop1_(); - } - comkeys_1.ornrpt = FALSE_; - } else { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - } - if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" - "acter in ornament symbol!", (ftnlen)128, ( - ftnlen)37); - stop1_(); - } - if (*(unsigned char *)dumq == ':') { - i__4 = a1ll_2.iccount; - if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 - - i__4, (ftnlen)1) != 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu" - "st be followed by blank in \"o: \"!", ( - ftnlen)128, (ftnlen)39); - stop1_(); - } else if (comkeys_1.ornrpt) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Turned o" - "n repeated ornaments but already on!", ( - ftnlen)128, (ftnlen)44); - stop1_(); - } - comkeys_1.ornrpt = TRUE_; - } - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - i__4 = a1ll_2.iccount; - if (i_indx("0123456789", lineq + i__4, (ftnlen)10, - a1ll_2.iccount + 1 - i__4) == 0) { - i__4 = a1ll_2.iccount + 1; - i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &i__4, &i__5, "There should be an" - " integer here!", (ftnlen)128, (ftnlen)32); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - if (*(unsigned char *)durq == ':') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot s" - "hift AND repeat an ornament!", (ftnlen) - 128, (ftnlen)36); - stop1_(); - } - -/* 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. */ - - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - i__4 = a1ll_2.iccount; - if (i_indx(".0123456789", lineq + i__4, (ftnlen) - 11, a1ll_2.iccount + 1 - i__4) == 0) { - i__4 = a1ll_2.iccount + 1; - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__4, &i__5, "There should b" - "e a number here!", (ftnlen)128, ( - ftnlen)30); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( - ftnlen)128, (ftnlen)1); - } - } - goto L110; - } else if (i_indx("st(){}", durq, (ftnlen)6, (ftnlen)1) > 0) { - -/* Slur in xtup */ - - iposn = 0; - numint = 0; -L15: - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - ++iposn; - if (i_indx("udlbfnht", dumq, (ftnlen)8, (ftnlen)1) > 0) { - if (*(unsigned char *)dumq == 't' && *(unsigned char * - )durq == 't') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot u" - "se \"t\" as an option on a tie!", (ftnlen) - 128, (ftnlen)37); - stop1_(); - } - goto L15; - } else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - ++numint; - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - if (numint == 1) { - if (i_nint(&fnum) > 30) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__4, &i__5, "Magnitude of s" - "lur height adjustment cannot exceed " - "30!", (ftnlen)128, (ftnlen)53); - stop1_(); - } - } else if (numint == 2) { - if (dabs(fnum) > 6.3f) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__4, &i__5, "Slur horiz shi" - "ft must be in the range (-6.3,6.3)!", - (ftnlen)128, (ftnlen)49); - stop1_(); - } - } else { - -/* Third signed integer, must be a midslur or curve spec. */ - - if (dabs(fnum) > 31.f) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__4, &i__5, "Slur midheight" - " must be in the range (-31,31)!", ( - ftnlen)128, (ftnlen)45); - stop1_(); - } - if (*(unsigned char *)durq == ':') { - -/* Expecting curve parameters. Get two numbers */ - - for (i__ = 1; i__ <= 2; ++i__) { - ++a1ll_2.iccount; - fnum = (real) (*(unsigned char *)&lineq[ - a1ll_2.iccount - 1] - 48); - if ((r__1 = fnum - 3.5f, dabs(r__1)) > - 3.6f) { - i__4 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, - "Slur curve parameter must " - "be in range (0,7)!", (ftnlen) - 128, (ftnlen)44); - stop1_(); - } -/* L40: */ - } - ++a1ll_2.iccount; - } - } - --a1ll_2.iccount; - goto L15; - } else if (*(unsigned char *)dumq == 's') { - -/* What follows should be one or two signed numbers for adjustment of line break */ -/* slur, end of 1st segment or start of second. */ - - if (comslur_1.fontslur) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "May not " - "use linebreak slur options with font-bas" - "ed slurs!", (ftnlen)128, (ftnlen)57); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "This cha" - "racter must be \"+\" or \"-\"!", (ftnlen) - 128, (ftnlen)34); - stop1_(); - } - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen) - 128, (ftnlen)1); - if (i_nint(&fnum) > 30) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &i__4, &i__5, "Magnitude of slur " - "height adjustment cannot exceed 30!", ( - ftnlen)128, (ftnlen)53); - stop1_(); - } - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, ( - ftnlen)128, (ftnlen)1); - if (dabs(fnum) > 6.3f) { - i__4 = a1ll_2.iccount - 1; - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__4, &i__5, "Slur horiz shi" - "ft must be in range (-6.3,6.3)!", ( - ftnlen)128, (ftnlen)45); - stop1_(); - } - } - --a1ll_2.iccount; - goto L15; - } else if (*(unsigned char *)dumq == 'H' && iposn > 1) { - i__4 = a1ll_2.iccount; - if (s_cmp(lineq + i__4, "H", a1ll_2.iccount + 1 - - i__4, (ftnlen)1) == 0) { - ++a1ll_2.iccount; - } - goto L15; - } else if (*(unsigned char *)dumq == 'p') { - -/* local change in postscript slur/tie adjustment default */ - - if (comslur_1.fontslur) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Must use" - " postscript slurs (\"Ap\") to use this o" - "ption!", (ftnlen)128, (ftnlen)52); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect" - "ed \"+\" or \"-\" here!", (ftnlen)128, ( - ftnlen)25); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect" - "ed \"s\" or \"t\" here!", (ftnlen)128, ( - ftnlen)25); - stop1_(); - } - goto L15; - } else if (*(unsigned char *)dumq != ' ') { - ic = *(unsigned char *)dumq; - if (ic >= 48 && ic <= 57 || ic >= 65 && ic <= 90) { - if (iposn == 1) { - if (*(unsigned char *)durq == 't' && - comslur_1.fontslur) { - i__4 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, - "Slur ID not allowed on non-post" - "script tie!", (ftnlen)128, ( - ftnlen)42); - stop1_(); - } - goto L15; - } - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Slur ID " - "must be 2nd character in slur symbol!", ( - ftnlen)128, (ftnlen)45); - stop1_(); - } - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" - "acter in slur symbol!", (ftnlen)128, (ftnlen) - 33); - stop1_(); - } - goto L110; - } else if (i_indx("0123456789#-nx_", durq, (ftnlen)15, ( - ftnlen)1) > 0) { - -/* We have a figure. Only allow on 1st note of xtup */ - - if (itup != 2) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Figure in xt" - "up only allowed on 1st note!", (ftnlen)128, ( - ftnlen)40); - stop1_(); - } else if (*(unsigned char *)durq == 'x') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "No floating " - "figures in xtuplets!", (ftnlen)128, (ftnlen) - 32); - stop1_(); - } - if (compage_1.usefig && c1ommvl_1.ivx == 1) { - *ifig = 1; - } -L26: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("0123456789#-n_.:", durq, (ftnlen)16, (ftnlen) - 1) > 0) { - goto L26; - } else if (*(unsigned char *)durq == 's') { - comligfont_1.isligfont = TRUE_; - goto L26; - } else if (*(unsigned char *)durq == '+') { - -/* vertical offset, must be integer then blank */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) != - 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Integer " - "for vertical offset expected here!", ( - ftnlen)128, (ftnlen)42); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - if (*(unsigned char *)durq != ' ') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Vertical" - " offset must terminate figure!", (ftnlen) - 128, (ftnlen)38); - stop1_(); - } - --a1ll_2.iccount; - goto L26; - } else if (*(unsigned char *)durq != ' ') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" - "acter in figure in xtuplet!", (ftnlen)128, ( - ftnlen)39); - stop1_(); - } - goto L110; - } else if (*(unsigned char *)durq == 'G') { - ngr = 1; -L79: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) - { - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - ngr = i_nint(&fnum); - --a1ll_2.iccount; - goto L79; - } else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1) - > 0) { - goto L79; - } else if (*(unsigned char *)charq == 'm') { - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, - (ftnlen)1); - if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0) - { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "A digit " - "less than 5 must follow \"m\" in a grace" - " note!", (ftnlen)128, (ftnlen)52); - stop1_(); - } - goto L79; - } else if (*(unsigned char *)charq == 'X') { - -/* Space before main note */ - - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, - (ftnlen)1); - if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen) - 1) > 0) { - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( - ftnlen)128, (ftnlen)1); - --a1ll_2.iccount; - goto L79; - } else { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "A number" - " must follow \"X\" in a grace note!", ( - ftnlen)128, (ftnlen)41); - stop1_(); - } - } - -/* At this point, charq is first note name in rest (grace?) */ - - i__4 = ngr; - for (igr = 1; igr <= i__4; ++igr) { - numnum = 0; - if (igr > 1) { -L75: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen) - 128, (ftnlen)1); - if (*(unsigned char *)charq == ' ') { - goto L75; - } - } - if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == - 0) { - i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__5, "In grace" - ", expected \"a\"-\"g\"!", (ftnlen)128, ( - ftnlen)27); - stop1_(); - } -L78: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, - (ftnlen)1); - if (*(unsigned char *)charq != ' ') { - if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1) - > 0) { - if (numnum == 1) { - i__5 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__5, - "Only one of \"+-1234567\" allow" - "ed here in grace!", (ftnlen)128, ( - ftnlen)46); - stop1_(); - } - numnum = 1; - goto L78; - } else if (i_indx("+-nfs", charq, (ftnlen)5, ( - ftnlen)1) > 0) { - goto L78; - } - -/* Digits are possible octave numbers */ - - i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__5, "Illegal " - "character after note name in grace!", ( - ftnlen)128, (ftnlen)43); - stop1_(); - } -/* L71: */ - } - goto L110; - } else /* if(complicated condition) */ { - chax_(ch__2, (ftnlen)1, &c__92); - if (*(unsigned char *)durq == *(unsigned char *)&ch__2[0]) - { - chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128); - if (literr > 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, literq + ( - literr - 1) * 51, (ftnlen)128, (ftnlen)51) - ; - stop1_(); - } - goto L110; - } else if (*(unsigned char *)durq == 'M') { - -/* Temporary trap until I get around putting this in pmxb */ - - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Macros not y" - "et allowed in xtuplets!", (ftnlen)128, ( - ftnlen)35); - stop1_(); - } else if (*(unsigned char *)durq == 'X') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - g1etx_(lineq, &a1ll_2.iccount, &c_false, & - comkeys_1.shifton, &i__4, &c1omnotes_1.udsp[ - c1omnotes_1.ibarcnt + a1ll_2.nbars], & - c1omnotes_1.wheadpt, (ftnlen)128); - goto L110; - } else if (*(unsigned char *)durq == 'z') { - -/* Chord note in xtup. Read past for now. */ - -L33: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)durq != ' ') { - goto L33; - } - goto L110; - } else if (*(unsigned char *)durq == 'D') { - -/* Dynamic mark */ - - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - checkdyn_(lineq, &a1ll_2.iccount, &i__4, (ftnlen)128); - goto L110; - } else if (*(unsigned char *)durq == '%') { - if (a1ll_2.iccount != 1) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Comment " - "must have \"%\" in column 1!", (ftnlen) - 128, (ftnlen)34); - stop1_(); - } - a1ll_2.iccount = 128; - goto L110; - } else if (*(unsigned char *)durq == '?') { - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)durq == ' ') { - --a1ll_2.iccount; - goto L110; - } - if (*(unsigned char *)durq != '-') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin" - "g \"-\"", (ftnlen)128, (ftnlen)13); - stop1_(); - } - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) - == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff - + a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin" - "g number", (ftnlen)128, (ftnlen)16); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) - 128, (ftnlen)1); - --a1ll_2.iccount; - goto L110; -/* +++ */ - } else /* if(complicated condition) */ { - i__4 = a1ll_2.iccount; - i__5 = a1ll_2.iccount + 1; - if (*(unsigned char *)durq == ']' && s_cmp(lineq + - i__4, "[", a1ll_2.iccount + 1 - i__4, (ftnlen) - 1) == 0 && s_cmp(lineq + i__5, " ", - a1ll_2.iccount + 2 - i__5, (ftnlen)1) == 0) { - a1ll_2.iccount += 2; - goto L110; -/* +++ */ - } - } - } - -/* End of xtup options. At this point symbol can only be note or rest */ - - if (i_indx("abcdefgr", durq, (ftnlen)8, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "In xtup, this ch" - "aracter is not allowed!", (ftnlen)128, (ftnlen)39) - ; - stop1_(); - } else if (*(unsigned char *)durq == 'r' && itup == ntup) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Sorry, PMX canno" - "t end an xtuplet with a rest!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } -L7: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("2345678ulcb", durq, (ftnlen)11, (ftnlen)1) > 0) { - goto L7; - } else if (i_indx("sfn", durq, (ftnlen)3, (ftnlen)1) > 0) { - -/* Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. */ - - i__4 = a1ll_2.iccount; - if (s_cmp(lineq + i__4, "i", a1ll_2.iccount + 1 - i__4, ( - ftnlen)1) == 0) { - ++a1ll_2.iccount; - } - goto L7; - } else if (i_indx("+-<>", durq, (ftnlen)4, (ftnlen)1) > 0) { - -/* May have either octave jump or shifted accid. on main xtup note */ - - i__4 = a1ll_2.iccount; - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0 && - i_indx("01234567890", lineq + i__4, (ftnlen)11, - a1ll_2.iccount + 1 - i__4) == 0) { - goto L7; - } - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, - (ftnlen)1); - --a1ll_2.iccount; - goto L7; - } else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Double an xtup note to make an unequal xtup */ - - c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - - 1] * 24 - 25] = bit_set(c1ommvl_1.nacc[ - c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25],18); - ++ndoub; - goto L7; - } else if (*(unsigned char *)durq == 'd') { - c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - - 1] * 24 - 25] = bit_set(c1ommvl_1.nacc[ - c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25],27); - goto L7; - } else if (*(unsigned char *)durq != ' ') { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal option o" - "n xtuplet note!", (ftnlen)128, (ftnlen)31); - stop1_(); - } - if (itup == ntup - ndoub) { - goto L3; - } -/* L6: */ - } -L3: - -/* 6==End of loop for xtuplet input */ - - ; - } else if (*(unsigned char *)durq == 'm') { - -/* Multi-bar rest: next 1 or two digits are # of bars. */ - - if (a1ll_2.itsofar[a1ll_2.iv - 1] % a1ll_2.lenbar != 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Multibar rest must start at be" - "ginning of bar!", (ftnlen)128, (ftnlen)45); - stop1_(); - } else if (a1ll_2.iv == 1 && c1omnotes_1.ibarmbr > 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Multibar rest only OK at one t" - "ime per block!", (ftnlen)128, (ftnlen)44); - stop1_(); - } - -/* For some purposes, pretend its one bar only */ - - a1ll_2.nodur[a1ll_2.iv + a1ll_2.nnl[a1ll_2.iv - 1] * 24 - 25] = - a1ll_2.lenbar; - c1omnotes_1.ibarmbr = a1ll_2.nbars + 1; - c1omnotes_1.mbrest = 0; -/* 20 call g1etchar(lineq,iccount,durq) */ - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected an integer " - "after \"rm\"!", (ftnlen)128, (ftnlen)31); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - c1omnotes_1.mbrest = i_nint(&fnum); - --a1ll_2.iccount; -/* if (ichar(durq).ge.48.and.ichar(durq).le.57) then */ -/* mbrest = 10*mbrest+ichar(durq)-48 */ -/* go to 20 */ -/* end if */ - if (a1ll_2.nv > 1) { - if (a1ll_2.iv == 1) { - comkeys_1.mbrestsav = c1omnotes_1.mbrest; - } else { - if (c1omnotes_1.mbrest != comkeys_1.mbrestsav) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must enter s" - "ame multi-bar rest in every voice!", (ftnlen) - 128, (ftnlen)46); - stop1_(); - } - } - -/* Zero out mbrestsav so can check at end of input block whether */ -/* all voices have one */ - - if (a1ll_2.iv == a1ll_2.nv) { - comkeys_1.mbrestsav = 0; - } - } - if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" - "ter \"rm\"!", (ftnlen)128, (ftnlen)29); - stop1_(); - } - } else if (*(unsigned char *)durq == '.') { - -/* Dotted pattern. Close out note. Mult time by 3/4. */ -/* Set time for next note to 1/4. Start the note. */ - - idotform = 1; - } else if (*(unsigned char *)durq == ',') { - idotform = 3; - -/* Now flow to duration setting, as if durq=' ' */ - - } else if (i_indx("oL", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Suppress full bar rest, or look left for height */ - - if (*(unsigned char *)charq != 'r') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",\"L\" options " - "only legal for rest, not note!", (ftnlen)128, (ftnlen) - 46); - stop1_(); - } - goto L2; - } else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Double note for xtup. Must check here in case "D" or "F" came before "x" or on */ -/* last note of xtup. Need to flag it in pmxa since affects horiz. spacing. */ - - c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[ - c1ommvl_1.ivx - 1] * 24 - 25],18); - goto L2; - } else if (*(unsigned char *)durq == 'A') { - -/* Main note accidental option */ - - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("o+-<>", durq, (ftnlen)5, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",+\",\"-\",\"" - "<\",\">\" are the only legal options here!", (ftnlen) - 128, (ftnlen)51); - stop1_(); - } - -/* Need more stuff here */ - - if (*(unsigned char *)durq != 'o') { - -/* Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will */ -/* proceed to number input checking */ - - --a1ll_2.iccount; - } - goto L2; - } else if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character!", ( - ftnlen)128, (ftnlen)18); - s_wsle(&io___595); - do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11); - i__1 = *(unsigned char *)durq; - do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer)); - e_wsle(); - stop1_(); - } - -/* End of block for note options. */ - -/* Set the duration */ - - if (idotform > 0) { - if (idotform == 1) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, ( - ftnlen)1) * 3 / 2; - } else if (idotform == 2) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[ - c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 3; - } else if (idotform == 3) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, ( - ftnlen)1); - } else if (idotform == 4) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[ - c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 2; - } - } else if (c1omnotes_1.ibarmbr != a1ll_2.nbars + 1 && ! fulbrp) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, (ftnlen)1); - -/* Check for double dot */ - - if (c1omnotes_1.iddot == 1) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[ - c1ommvl_1.ivx - 1] * 24 - 25] * 7 / 6; - c1omnotes_1.iddot = 0; - } - } else if (fulbrp) { - a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - - 25] = a1ll_2.lenbar; - -/* Use a one-line function to set nnodur. It gives inverse of ifnodur. */ - - i__1 = (integer) (log(a1ll_2.lenbar + .1f) / .69315f) + 48; - chax_(ch__2, (ftnlen)1, &i__1); - c1omnotes_1.nnodur = i_indx("62514x0x37", ch__2, (ftnlen)10, ( - ftnlen)1) - 1; - fulbrp = FALSE_; - } - a1ll_2.rest[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25] = - *(unsigned char *)charq == 'r'; - -/* If inside forced beam, check if note is beamable */ - - if (c1omget_1.fbon) { - if (a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * - 24 - 25] < 16) { - goto L120; - } - if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 1) { - if (a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[c1ommvl_1.ivx - - 1] - 1) * 24 - 25] == 0) { - goto L120; - } - } - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Unbeamable thing in forc" - "ed beam!", (ftnlen)128, (ftnlen)32); - stop1_(); - } -L120: - -/* Get number of prior bars for later check on whether note spans bar line */ - - nbb4 = a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar; - a1ll_2.itsofar[c1ommvl_1.ivx - 1] += a1ll_2.nodur[c1ommvl_1.ivx + - a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25]; - if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] % a1ll_2.lenbar == 0) { - ++a1ll_2.nbars; - if (comkeys_1.shifton) { - comkeys_1.barend = TRUE_; - } - -/* Will check barend when 1st note of next bar is entered. */ - - if (a1ll_2.nbars > 15) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot have more tha" - "n 15 bars in an input block!", (ftnlen)128, (ftnlen) - 48); - stop1_(); - } - a1ll_2.nib[c1ommvl_1.ivx + a1ll_2.nbars * 24 - 25] = a1ll_2.nnl[ - c1ommvl_1.ivx - 1]; - if (a1ll_2.firstline && a1ll_2.lenbar != a1ll_2.lenbr1) { - -/* Just finished the pickup bar for this voice. */ - - if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] != a1ll_2.lenbr0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Pickup bar lengt" - "h disagrees with mtrnum0!", (ftnlen)128, (ftnlen) - 41); - stop1_(); - } - a1ll_2.lenbar = a1ll_2.lenbr1; - a1ll_2.itsofar[c1ommvl_1.ivx - 1] = 0; - } - } else if (comkeys_1.barend) { - if (comkeys_1.shifton) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar ended with user-" - "defined shift still on!", (ftnlen)128, (ftnlen)43); - stop1_(); - } - comkeys_1.barend = FALSE_; - } else if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar > nbb4) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &i__1, &i__4, "This note spans a bar line!", ( - ftnlen)128, (ftnlen)27); - stop1_(); - } - if (idotform == 1 || idotform == 3) { - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("abcedfgr", charq, (ftnlen)8, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected note name o" - "r \"r\" here!", (ftnlen)128, (ftnlen)31); - stop1_(); - } - ++idotform; - numnum = 1; - goto L28; - } - -/* End of sub block for note-rest */ - - } else if (*(unsigned char *)charq == 'z') { - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected chord note name" - " here!", (ftnlen)128, (ftnlen)30); - stop1_(); - } -L25: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); -/* if (index('dre12345678',durq) .gt. 0) then */ - if (i_indx("dre12345678c", durq, (ftnlen)12, (ftnlen)1) > 0) { - goto L25; - } else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) { - -/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */ -/* MUST come right after "f,s,n" */ - - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1) - == 0) { - ++a1ll_2.iccount; - } - goto L25; - } else if (*(unsigned char *)durq == 'A') { - i__1 = a1ll_2.iccount - 2; - if (i_indx("fsn", lineq + i__1, (ftnlen)3, a1ll_2.iccount - 1 - - i__1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n\" before \"" - "A\" in chord note!", (ftnlen)128, (ftnlen)43); - stop1_(); - } - goto L25; - } else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) { - i__1 = a1ll_2.iccount - 2; - if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 - - i__1) == 0) { -/* if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems */ - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n,A\" before" - " \"<\" or \">\"!", (ftnlen)128, (ftnlen)38); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("1234567890.", durq, (ftnlen)11, (ftnlen)1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Expected a number to start her" - "e for accidental shift!", (ftnlen)128, (ftnlen)53); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - goto L25; - } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - i__1 = a1ll_2.iccount; - if (i_indx("1234567890.", lineq + i__1, (ftnlen)11, - a1ll_2.iccount + 1 - i__1) == 0) { - goto L25; - } - -/* Number or '.' (durq) follows +/- . Get it. */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - i__1 = a1ll_2.iccount; - if (*(unsigned char *)durq == '.' && i_indx("1234567890", lineq + - i__1, (ftnlen)10, a1ll_2.iccount + 1 - i__1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "\".\" here must be followed by" - " a digit!", (ftnlen)128, (ftnlen)37); - stop1_(); - } else /* if(complicated condition) */ { - i__1 = a1ll_2.iccount - 3; - if (i_indx("sfndA", lineq + i__1, (ftnlen)5, a1ll_2.iccount - - 2 - i__1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Number after +/- must foll" - "ow \"d,s,f,n,A\"!", (ftnlen)128, (ftnlen)41); - stop1_(); - } - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) { - --a1ll_2.iccount; - goto L25; - } - -/* 2nd +/- */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)durq == '.') { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - } - if (i_indx("1234567890", durq, (ftnlen)10, (ftnlen)1) == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Expected a number here!", ( - ftnlen)128, (ftnlen)23); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - goto L25; - } else if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in cho" - "rd note!", (ftnlen)128, (ftnlen)32); - stop1_(); - } - } else if (*(unsigned char *)charq == 'G') { - ngr = 1; -L9: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) { - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - ngr = i_nint(&fnum); - --a1ll_2.iccount; - goto L9; - } else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1) > 0) { - goto L9; - } else if (*(unsigned char *)charq == 'm') { - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "A digit less than 5 " - "must follow \"m\" in a grace note!", (ftnlen)128, ( - ftnlen)52); - stop1_(); - } - goto L9; - } else if (*(unsigned char *)charq == 'X') { - -/* Space before main note */ - - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen)1) > 0) { - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - goto L9; - } else { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "A number must foll" - "ow \"X\" in a grace note!", (ftnlen)128, (ftnlen)41); - stop1_(); - } - } - -/* At this point, charq is first note name in rest (grace?) */ - - i__1 = ngr; - for (igr = 1; igr <= i__1; ++igr) { - numnum = 0; - if (igr > 1) { -L55: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)charq == ' ') { - goto L55; - } - } - if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "In grace, expected" - " \"a\"-\"g\"!", (ftnlen)128, (ftnlen)27); - stop1_(); - } -L18: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)charq != ' ') { - if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1) > 0) { - if (numnum == 1) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Only one of" - " \"+-1234567\" allowed here in grace!", ( - ftnlen)128, (ftnlen)46); - stop1_(); - } - numnum = 1; - goto L18; -/* else if (index('nfs',charq) .gt. 0) then */ - } else if (i_indx("+-nfs", charq, (ftnlen)5, (ftnlen)1) > 0) { - goto L18; - } - -/* Digits are possible octave numbers */ - - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal character af" - "ter note name in grace!", (ftnlen)128, (ftnlen)43); - stop1_(); - } -/* L19: */ - } - } else /* if(complicated condition) */ { - chax_(ch__2, (ftnlen)1, &c__92); - if (*(unsigned char *)charq == *(unsigned char *)&ch__2[0]) { - chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128); - if (literr > 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, literq + (literr - 1) * - 51, (ftnlen)128, (ftnlen)51); - stop1_(); - } - } else if (*(unsigned char *)charq == 'o') { - -/* Ornament on non-xtup note. "o" symbol must come AFTER the affected note */ - - if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\" must be in sam" - "e input block, after affected note!", (ftnlen)128, ( - ftnlen)53); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1); - if (i_indx("(stmgx+Tupf._)e:>^bc", dumq, (ftnlen)20, (ftnlen)1) == - 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal ornament!", ( - ftnlen)128, (ftnlen)17); - stop1_(); - } - if (*(unsigned char *)dumq == ':') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)dumq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected blank a" - "fter \"o:\"!", (ftnlen)128, (ftnlen)26); - stop1_(); - } else if (! comkeys_1.ornrpt) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Turned off repeated orname" - "nts before they were on!", (ftnlen)128, (ftnlen) - 50); - stop1_(); - } - comkeys_1.ornrpt = FALSE_; - } else if (*(unsigned char *)dumq == 'g') { - if (c1omget_1.issegno) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Sorry, only one" - " \"segno\" per input block!", (ftnlen)128, ( - ftnlen)40); - stop1_(); - } else if (c1ommvl_1.ivx != 1) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "segno can only b" - "e in voice 1!", (ftnlen)128, (ftnlen)29); - stop1_(); - } - c1omget_1.issegno = TRUE_; -L12: - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)dumq == '-' || *(unsigned char *)dumq >= - 48 && *(unsigned char *)dumq <= 58) { - goto L12; - } - if (*(unsigned char *)dumq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r in segno ornament symbol!", (ftnlen)128, ( - ftnlen)43); - stop1_(); - } - } else if (*(unsigned char *)dumq == 'T') { - -/* Trill. may be followed by 't' and/or number. read 'til blank */ - -L22: - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)dumq == ':') { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) != 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected bla" - "nk after \":\"!", (ftnlen)128, (ftnlen)25); - stop1_(); - } - goto L32; - } else if (*(unsigned char *)dumq != ' ') { - goto L22; - } - } else if (*(unsigned char *)dumq == 'f') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (i_indx(" d+-:", dumq, (ftnlen)5, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r after \"f\" in fermata ornament symbol!", ( - ftnlen)128, (ftnlen)55); - stop1_(); - } - if (*(unsigned char *)dumq == 'd') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - } - if (*(unsigned char *)dumq == ':') { - goto L32; - } - } else if (*(unsigned char *)dumq == 'e') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r after \"e\" in edit. accid. symbol!", (ftnlen) - 128, (ftnlen)51); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)dumq == '?') { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( - ftnlen)1); - } - } else { - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - } - if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in" - " ornament symbol!", (ftnlen)128, (ftnlen)37); - stop1_(); - } - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - i__1 = a1ll_2.iccount; - if (i_indx("0123456789", lineq + i__1, (ftnlen)10, - a1ll_2.iccount + 1 - i__1) == 0) { - i__1 = a1ll_2.iccount + 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "There should be an integer" - " here!", (ftnlen)128, (ftnlen)32); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)durq == ':') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot shift AND" - " repeat an ornament!", (ftnlen)128, (ftnlen)36); - stop1_(); - } - -/* 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. */ - - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - i__1 = a1ll_2.iccount; - if (i_indx(".0123456789", lineq + i__1, (ftnlen)11, - a1ll_2.iccount + 1 - i__1) == 0) { - i__1 = a1ll_2.iccount + 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "There should be a numb" - "er here!", (ftnlen)128, (ftnlen)30); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, - (ftnlen)1); - } - } -L32: - if (*(unsigned char *)dumq == ':') { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) != 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\":\" must be fo" - "llowed by blank in \"o: \"!", (ftnlen)128, ( - ftnlen)39); - stop1_(); - } else if (comkeys_1.ornrpt) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on repeat" - "ed ornaments but already on!", (ftnlen)128, ( - ftnlen)44); - stop1_(); - } - comkeys_1.ornrpt = TRUE_; - } - } else if (i_indx("st(){}", charq, (ftnlen)6, (ftnlen)1) > 0) { - numint = 0; - iposn = 0; -L8: - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1); - ++iposn; - if (*(unsigned char *)charq == 't' && *(unsigned char *)dumq == - 't') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot use \"t\" as " - "an option on a tie!", (ftnlen)128, (ftnlen)37); - stop1_(); - } - if (i_indx("udltb+-fnhHps ", dumq, (ftnlen)14, (ftnlen)1) == 0) { - -/* Check for explicit ID code. */ - - ic = *(unsigned char *)dumq; - if (ic < 48 || ic > 57 && ic < 65 || ic > 90) { - -/* Not 0-9 or A-Z, so exit */ - - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r in slur symbol!", (ftnlen)128, (ftnlen)33); - stop1_(); - } else { - -/* It is a possible ID code. Right place? */ - - if (iposn != 1) { - -/* Slur ID is not 2nd! */ - - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID must" - " be second character in slur symbol!", ( - ftnlen)128, (ftnlen)48); - stop1_(); - } else if (*(unsigned char *)charq == 't' && - comslur_1.fontslur) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID not " - "allowed on non-postscript tie!", (ftnlen)128, - (ftnlen)42); - stop1_(); - } - } - -/* Slur ID is OK. Note it cannot be "H" at this point.. */ - - goto L8; - } else if (*(unsigned char *)dumq == 'H') { - if (iposn == 1) { - goto L8; - } - -/* "H" is NOT an ID code. */ - - if (! comslur_1.fontslur && *(unsigned char *)charq == 't') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape p" - "ostscript ties this way!", (ftnlen)128, (ftnlen) - 40); - stop1_(); - } - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) == 0) { - ++a1ll_2.iccount; - ++iposn; - } - goto L8; - } else if (i_indx("fh", dumq, (ftnlen)2, (ftnlen)1) > 0 && ! - comslur_1.fontslur && *(unsigned char *)charq == 't') { - -/* 3/9/03 Can't reshape postscript tie. */ - - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape posts" - "cript ties this way!", (ftnlen)128, (ftnlen)40); - stop1_(); - } else if (*(unsigned char *)dumq == 'p') { - -/* local change in postscript slur/tie adjustment default */ - - if (comslur_1.fontslur) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must use postscr" - "ipt slurs (\"Ap\") to use this option!", (ftnlen) - 128, (ftnlen)52); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"+\" o" - "r \"-\" here!", (ftnlen)128, (ftnlen)25); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"s\" o" - "r \"t\" here!", (ftnlen)128, (ftnlen)25); - stop1_(); - } - iposn += 2; - goto L8; - } - if (i_indx("udltbfnh", dumq, (ftnlen)8, (ftnlen)1) > 0) { - goto L8; - } else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - ++numint; - if (comslur_1.fontslur && *(unsigned char *)charq == 't') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+|-\" for slur" - " height only allowed in \"s\"-slurs!", (ftnlen) - 128, (ftnlen)48); - stop1_(); - } - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (numint == 1) { - if (i_nint(&fnum) > 30) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Magnitude of slur heig" - "ht adjustment cannot exceed 30!", (ftnlen)128, - (ftnlen)53); - stop1_(); - } - } else if (numint == 2) { - if (dabs(fnum) > 6.3f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must " - "be in range (-6.3,6.3)!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - } else { - -/* Third signed integer, must be a midslur or curve spec. */ - - if (dabs(fnum) > 31.f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Slur midheight must be" - " in the range (-31,31)!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - if (*(unsigned char *)durq == ':') { - -/* Expecting curve parameters. Get two numbers */ - - for (i__ = 1; i__ <= 2; ++i__) { - ++a1ll_2.iccount; - fnum = (real) (*(unsigned char *)&lineq[ - a1ll_2.iccount - 1] - 48); - if ((r__1 = fnum - 3.5f, dabs(r__1)) > 3.6f) { - i__1 = c1omnotes_1.ibarcnt - - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur" - " curve parameter must be in range (0" - ",7)!", (ftnlen)128, (ftnlen)44); - stop1_(); - } -/* L41: */ - } - ++a1ll_2.iccount; - } - } - --a1ll_2.iccount; - goto L8; - } else if (*(unsigned char *)dumq == 's') { - -/* What follows should be one or two signed numbers for adjustment of line break */ -/* slur, end of 1st segment or start of second. */ - - if (comslur_1.fontslur) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "May not use line" - "break slur options with font-based slurs!", ( - ftnlen)128, (ftnlen)57); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "This character m" - "ust be \"+\" or \"-\"!", (ftnlen)128, (ftnlen)34); - stop1_(); - } - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (i_nint(&fnum) > 30) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Magnitude of slur height a" - "djustment cannot exceed 30!", (ftnlen)128, ( - ftnlen)53); - stop1_(); - } - if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, - (ftnlen)1); - if (dabs(fnum) > 6.3f) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must " - "be in range (-6.3,6.3)!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - } - --a1ll_2.iccount; - goto L8; - } else if (*(unsigned char *)dumq == 'H' && iposn > 1) { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) == 0) { - ++a1ll_2.iccount; - } - goto L8; - } - } else if (*(unsigned char *)charq == '?') { - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)durq == ' ') { - --a1ll_2.iccount; - } else { - if (*(unsigned char *)durq != '-') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting \"-\"!", - (ftnlen)128, (ftnlen)14); - stop1_(); - } - getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1) - ; - if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting number!" - , (ftnlen)128, (ftnlen)17); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - } - } else if (*(unsigned char *)charq >= 48 && *(unsigned char *)charq <= - 57 || i_indx("#-nx_", charq, (ftnlen)5, (ftnlen)1) > 0) { - -/* We have a figure. Must come AFTER the note it goes under */ - - if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] == 0 && (! a1ll_2.firstline - || a1ll_2.lenbr0 == 0 || a1ll_2.lenbar == a1ll_2.lenbr0)) - { - -/* Figure before first note in block */ - - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot put figure be" - "fore first note in block!", (ftnlen)128, (ftnlen)45); - stop1_(); - } - if (*(unsigned char *)charq == 'x') { - indxb = i_indx(lineq + (a1ll_2.iccount - 1), " ", 128 - ( - a1ll_2.iccount - 1), (ftnlen)1); - if (indxb < 5) { - i__1 = a1ll_2.iccount + indxb - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Cannot have a blank here i" - "n floating figure!", (ftnlen)128, (ftnlen)44); - stop1_(); - } - } - if (compage_1.usefig) { - *ifig = 1; - } -L5: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx(" 0123456789#-nx_.:+s", charq, (ftnlen)20, (ftnlen)1) - == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in" - " figure!", (ftnlen)128, (ftnlen)28); - stop1_(); - } else if (*(unsigned char *)charq == '+') { - -/* vertical offset, must be integer, then blank */ - - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Integer for vert" - "ical offset expected here!", (ftnlen)128, (ftnlen) - 42); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, charq, &fnum, (ftnlen)128, ( - ftnlen)1); - if (*(unsigned char *)charq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Vertical offset " - "must terminate figure!", (ftnlen)128, (ftnlen)38); - stop1_(); - } - --a1ll_2.iccount; - goto L5; - } else if (*(unsigned char *)charq == 's') { - comligfont_1.isligfont = TRUE_; - } - if (*(unsigned char *)charq != ' ') { - goto L5; - } - } else if (*(unsigned char *)charq == '[') { - if (c1omget_1.fbon) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Started forced beam " - "while another was open!", (ftnlen)128, (ftnlen)43); - stop1_(); - } - c1omget_1.fbon = TRUE_; -L17: - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (i_indx("uljhf:", charq, (ftnlen)6, (ftnlen)1) > 0) { - goto L17; - } else if (i_indx("+-", charq, (ftnlen)2, (ftnlen)1) > 0) { - ++a1ll_2.iccount; - readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( - ftnlen)1); - --a1ll_2.iccount; - goto L17; - } else if (*(unsigned char *)charq == 'm') { - -/* Forced multiplicity, next char should be 1-4 */ - - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("1234", charq, (ftnlen)4, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced multiplic" - "ity for a beam must be 1, 2, 3, or 4!", (ftnlen) - 128, (ftnlen)53); - stop1_(); - } - goto L17; - } else if (*(unsigned char *)charq != ' ') { - if (i_indx("0123456789", charq, (ftnlen)10, (ftnlen)1) > 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "After \"[\", dig" - "its must now be preceeded by \"+\" or \"-\"!", ( - ftnlen)128, (ftnlen)54); - s_wsle(&io___598); - do_lio(&c__9, &c__1, "You will have to edit older source" - "s to meet this rqmt,", (ftnlen)54); - e_wsle(); - s_wsle(&io___599); - do_lio(&c__9, &c__1, "but it was needed to allow 2-digit" - " height adjustments.", (ftnlen)54); - e_wsle(); - s_wsle(&io___600); - do_lio(&c__9, &c__1, "Sorry for the inconvenience. --Th" - "e Management", (ftnlen)46); - e_wsle(); - } else { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" - "r after [!", (ftnlen)128, (ftnlen)26); - } - stop1_(); - } - } else if (*(unsigned char *)charq == ']') { - if (! c1omget_1.fbon) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced beam stop wit" - "h no corresponding start!", (ftnlen)128, (ftnlen)45); - stop1_(); - } - g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)charq == '-') { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, "[ ", a1ll_2.iccount + 2 - i__1, ( - ftnlen)2) != 0) { - i__1 = a1ll_2.iccount + 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Only sequence allowed here" - " is \"[ \"!", (ftnlen)128, (ftnlen)35); - stop1_(); - } else { - a1ll_2.iccount += 2; - } - } else if (*(unsigned char *)charq == '[') { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) != 0) { - i__1 = a1ll_2.iccount + 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "This character must be a b" - "lank!", (ftnlen)128, (ftnlen)31); - stop1_(); - } - } else { - -/* Forced beam is really ending */ - - c1omget_1.fbon = FALSE_; - if (*(unsigned char *)charq == 'j') { - i__1 = a1ll_2.iccount; - if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( - ftnlen)1) != 0) { - i__1 = a1ll_2.iccount + 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "This character must be" - " a blank!", (ftnlen)128, (ftnlen)31); - stop1_(); - } - } else if (*(unsigned char *)charq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"]\" must be fo" - "llowed by blank, \"j\", \"-\", or \"[\"!", ( - ftnlen)128, (ftnlen)48); - stop1_(); - } - } - } else if (*(unsigned char *)charq == 'D') { - -/* Dynamic mark */ - - if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"D\" must not come " - "before any notes have been entered!", (ftnlen)128, ( - ftnlen)53); - stop1_(); - } - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + - 1; - checkdyn_(lineq, &a1ll_2.iccount, &i__1, (ftnlen)128); - } else if (i_indx("lhw", charq, (ftnlen)3, (ftnlen)1) > 0) { - -/* Save position for later check */ - - icclhw = a1ll_2.iccount; - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("0123456789.+- ", durq, (ftnlen)14, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" - "ter \"l\", \"w\", or \"h\"!", (ftnlen)128, (ftnlen)41) - ; - stop1_(); - } - c1omget_1.isheadr = c1omget_1.isheadr || *(unsigned char *)charq - == 'h'; - if (i_indx(" +-", durq, (ftnlen)3, (ftnlen)1) > 0) { - -/* There is a header (or lower string?) */ - - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* User-defined vert offset (\internote). */ - - if (*(unsigned char *)charq != 'h') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+\" or \"" - "-\" not permitted here!", (ftnlen)128, ( - ftnlen)30); - stop1_(); - } - -/* Have "h" followed by +/- . Check for digit. */ -/* Can blow durq since not using fnum for now, but... */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) - { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must b" - "e a digit here!", (ftnlen)128, (ftnlen)27); - stop1_(); - } - -/* Have "h" followed by +/- followed by a digit. No need to get the number. */ - -/* call readnum(lineq,iccount,durq,fnum) */ - } - if (*(unsigned char *)charq != 'w') { - -/* Header or lower string. */ - - if (icclhw != 1) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "\"h\" or \"l\" must be" - " first character in line!", (ftnlen)128, ( - ftnlen)43); - stop1_(); - } - -/* Read past the next line, which has the string. */ - - read10_(charq, &c1omget_1.lastchar, (ftnlen)1); - ++c1omget_1.nline; - a1ll_2.iccount = 128; - } else { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol \"w\" (wi" - "dth) must be followed by a digit!", (ftnlen)128, ( - ftnlen)47); - stop1_(); - } - } else { - -/* Height or width change spec. Check if at start of piece. */ - - if (c1omnotes_1.ibarcnt > 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol must go a" - "t top of first input block!", (ftnlen)128, ( - ftnlen)43); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &dimen, (ftnlen)128, ( - ftnlen)1); - -/* Check units. Convert to points */ - - if (*(unsigned char *)durq == ' ' || *(unsigned char *)durq == - 'p') { - dimen += .5f; - } else if (*(unsigned char *)durq == 'i') { - dimen = dimen * 72 + .5f; - } else if (*(unsigned char *)durq == 'm') { - dimen = dimen / 25.4f * 72 + .5f; - } else { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal unit; mu" - "st be \"p\",\"i\",or\"m\"!", (ftnlen)128, (ftnlen) - 36); - stop1_(); - } - if (*(unsigned char *)charq == 'h') { - compage_1.ptheight = (real) ((integer) dimen); - } else { - compage_1.widthpt = (real) ((integer) dimen); - } - } - } else if (*(unsigned char *)charq == 'm') { - -/* Time signature change. Only allow at beginning of block. */ -/* mtrnuml, mtrdenl (logical) and p (printable) will be input. */ -/* mtrnuml=0 initially. (In common) */ - -/* Check whether at beginning of a block */ - - if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Meter change only OK" - " in voice 1, at start of block!", (ftnlen)128, ( - ftnlen)51); - s_wsle(&io___603); - do_lio(&c__9, &c__1, "voice number is", (ftnlen)15); - do_lio(&c__3, &c__1, (char *)&c1ommvl_1.ivx, (ftnlen)sizeof( - integer)); - e_wsle(); - stop1_(); - } - a1ll_2.newmeter = TRUE_; - readmeter_(lineq, &a1ll_2.iccount, &a1ll_2.mtrnuml, &mtrdenl, ( - ftnlen)128); - if (a1ll_2.mtrnuml == 0) { - i__1 = a1ll_2.iccount - 1; - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &i__1, &i__4, "Digit 0 not allowed here!", ( - ftnlen)128, (ftnlen)25); - stop1_(); -/* else if (mtrdenl .eq. 1) then */ -/* c */ -/* c Kluge!!! */ -/* c */ -/* mtrdenl = 2 */ -/* mtrnuml = 2*mtrnuml */ - } - readmeter_(lineq, &a1ll_2.iccount, &mtrnmp, &mtrdnp, (ftnlen)128); - -/* Read past printed time signature; not used in pmxa. */ - - lenbeat = i1fnodur_(&mtrdenl, "x", (ftnlen)1); - lenmult = 1; - if (mtrdenl == 2) { - lenbeat = 16; - lenmult = 2; - } - a1ll_2.lenbar = lenmult * a1ll_2.mtrnuml * lenbeat; - a1ll_2.mtrnuml = 0; - } else if (*(unsigned char *)charq == 'C') { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (! (i_indx("tsmanrbf", durq, (ftnlen)8, (ftnlen)1) > 0 || *( - unsigned char *)durq >= 48 && *(unsigned char *)durq <= - 55)) { -/* * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then */ - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have t,s,m,a,n," - "r,b,f or 1-7 after C!", (ftnlen)128, (ftnlen)41); -/* * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') */ - stop1_(); - } - c1omnotes_1.gotclef = TRUE_; - } else if (*(unsigned char *)charq == 'R') { - if (c1ommvl_1.ivx != 1) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Repeats can only go " - "in voice 1!", (ftnlen)128, (ftnlen)31); - stop1_(); - } -L10: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("lrdDbz", durq, (ftnlen)6, (ftnlen)1) > 0) { - goto L10; - } - if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" - "ter \"R\" (repeat/double bar)!", (ftnlen)128, (ftnlen) - 48); - stop1_(); - } - } else if (*(unsigned char *)charq == 'V') { - -/* Ending */ - - if (a1ll_2.iv != 1) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Voltas are only allo" - "wed in voice #1!", (ftnlen)128, (ftnlen)36); - stop1_(); - } else if (c1omget_1.isvolt) { - s_wsle(&io___609); - e_wsle(); - s_wsle(&io___610); - do_lio(&c__9, &c__1, "*******WARNING********", (ftnlen)22); - e_wsle(); - s_wsfe(&io___611); - do_fio(&c__1, "*******WARNING********", (ftnlen)22); - e_wsfe(); - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "There is more than o" - "ne volta in this input block.!", (ftnlen)128, (ftnlen) - 50); - s_wsle(&io___612); - do_lio(&c__9, &c__1, "This may work in a score, but WILL NOT" - " work in parts.", (ftnlen)53); - e_wsle(); - s_wsle(&io___613); - do_lio(&c__9, &c__1, "Safest to have only 1 volta per block," - " at the start of the block", (ftnlen)64); - e_wsle(); - s_wsfe(&io___614); - do_fio(&c__1, "This may work in a score, but WILL NOT work i" - "n parts.", (ftnlen)53); - e_wsfe(); - s_wsfe(&io___615); - do_fio(&c__1, "Safest to have only 1 volta per block, at the" - " start of the block", (ftnlen)64); - e_wsfe(); - } - c1omget_1.isvolt = TRUE_; - lvoltxt = 0; -L11: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)durq != ' ') { - goto L11; - } - } else if (*(unsigned char *)charq == 'B') { - } else if (*(unsigned char *)charq == 'P') { - if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only allowed at begi" - "nning of block!", (ftnlen)128, (ftnlen)35); - stop1_(); - } -L16: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (*(unsigned char *)durq == 'l' || *(unsigned char *)durq == - 'r' || *(unsigned char *)durq >= 48 && *(unsigned char *) - durq <= 57) { - goto L16; - } - if (*(unsigned char *)durq == 'c') { - -/* Expect a centered name, and it has to be last option */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (*(unsigned char *)durq == '"') { - -/* Quoted name, go to next quote mark */ - - for (++a1ll_2.iccount; a1ll_2.iccount <= 127; - ++a1ll_2.iccount) { - if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] == - '"') { - goto L36; - } -/* L35: */ - } - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Missing close qu" - "ote after page number command (P)!", (ftnlen)128, - (ftnlen)50); - stop1_(); -L36: - ; - } else if (*(unsigned char *)durq != ' ') { - -/* Space-delimited name, look for next blank */ - - for (++a1ll_2.iccount; a1ll_2.iccount <= 127; - ++a1ll_2.iccount) { - if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] == - ' ') { - goto L38; - } -/* L37: */ - } -L38: - ; - } - } else if (*(unsigned char *)durq != ' ') { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only \"l\",\"r\",\"" - "c\" or digit allowed after \"P\"!", (ftnlen)128, ( - ftnlen)44); - stop1_(); - } - } else if (*(unsigned char *)charq == 'W') { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx(".0123456789", durq, (ftnlen)11, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected a number to" - " start here!", (ftnlen)128, (ftnlen)32); - stop1_(); - } - readnum_(lineq, &a1ll_2.iccount, durq, &c1omnotes_1.wminnh[ - c1omnotes_1.ibarcnt + a1ll_2.nbars], (ftnlen)128, (ftnlen) - 1); - } else if (*(unsigned char *)charq == 'T') { - -/* Titles */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("itc", durq, (ftnlen)3, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must put \"i\", \"" - "t\", or \"c\" after \"T\"!", (ftnlen)128, (ftnlen)36); - stop1_(); - } - i__1 = i_indx("itc", durq, (ftnlen)3, (ftnlen)1) - 1; - c1omget_1.ihead += pow_ii(&c__2, &i__1); - -/* Maybe a number after 'Tt', but ignore here. Read past string on next line. */ - - read10_(charq, &c1omget_1.lastchar, (ftnlen)1); - ++c1omget_1.nline; - a1ll_2.iccount = 128; - } else if (*(unsigned char *)charq == 'A') { -L27: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); - if (i_indx("rbsdeK", durq, (ftnlen)6, (ftnlen)1) > 0) { - goto L27; - } else if (*(unsigned char *)durq == 'v') { - if (c1omnotes_1.ibarcnt == 0) { - comnvst_1.novshrinktop = TRUE_; - } - goto L27; - } else if (*(unsigned char *)durq == 'a') { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - readnum_(lineq, &a1ll_2.iccount, durq, &c1ommvl_1.fbar, ( - ftnlen)128, (ftnlen)1); - --a1ll_2.iccount; - goto L27; - } else if (*(unsigned char *)durq == 'i') { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - -/* Local interstaff correction. Set to -1. if not specifiec, or after use, */ -/* or anytime except at top, since pmxb handles all times except at top. */ - - readnum_(lineq, &a1ll_2.iccount, durq, &tintstf, (ftnlen)128, - (ftnlen)1); - if (c1omnotes_1.ibarcnt == 0) { - compage_1.fintstf = tintstf; - } - --a1ll_2.iccount; - goto L27; - } else if (*(unsigned char *)durq == 'I') { - -/* Global interstaff correction. Use in place of fintstf if fintstf<0 */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - readnum_(lineq, &a1ll_2.iccount, durq, &compage_1.gintstf, ( - ftnlen)128, (ftnlen)1); - --a1ll_2.iccount; - goto L27; - } else if (*(unsigned char *)durq == 'o') { - *optimize = TRUE_; - goto L27; - } else if (*(unsigned char *)durq == 'S') { - i__1 = a1ll_2.nv; - for (iiv = 1; iiv <= i__1; ++iiv) { - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("-0st", durq, (ftnlen)4, (ftnlen)1) == 0) { - i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__4, "After \"AS\"" - ", need nv instances of \"s,t,-,0\"!", (ftnlen) - 128, (ftnlen)43); - stop1_(); - } - if (*(unsigned char *)durq == '-' || *(unsigned char *) - durq == 's') { - comsize_1.isize[iiv - 1] = 1; - } else if (*(unsigned char *)durq == 't') { - comsize_1.isize[iiv - 1] = 2; - } -/* L50: */ - } - goto L27; - } else if (*(unsigned char *)durq == 'p') { - comslur_1.fontslur = FALSE_; -L42: - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) - 1); - if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Characters to change defaults for ps slurs */ - - g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( - ftnlen)1); - if (i_indx("shtc", durq, (ftnlen)4, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only letters" - " allowed here are \"s\",\"h\",\"t\",\"c\"!", ( - ftnlen)128, (ftnlen)46); - stop1_(); - } - -/* Now check for another default modifier */ - - goto L42; - } else if (i_indx("lh", durq, (ftnlen)2, (ftnlen)1) > 0) { - -/* Flags for optional linebreak ties or header specials */ - - goto L42; - } else { - --a1ll_2.iccount; - } - goto L27; - } else if (*(unsigned char *)durq == 'N') { - -/* Override default name for a part file. Must have part number, then */ -/* partname in quotes. Must be on line by itself, and start in column 1. */ -/* Will only be passed thru to scor2prt. */ - - if (a1ll_2.iccount != 2) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must star" - "t in column 1!", (ftnlen)128, (ftnlen)28); - stop1_(); - } - ndxquote = i_indx(lineq, "\"", (ftnlen)128, (ftnlen)1); - if (ndxquote < 4 || ndxquote > 5 || i_indx("123456789", lineq - + 2, (ftnlen)9, (ftnlen)1) == 0 || ndxquote == 5 && - i_indx("012", lineq + 3, (ftnlen)3, (ftnlen)1) == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must be f" - "ollowed by inst. #, then quote!", (ftnlen)128, ( - ftnlen)45); - stop1_(); - } - i__1 = ndxquote; - ndxquote = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1); - if (ndxquote == 0) { - i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + - a1ll_2.nbars + 1; - errmsg_(lineq, &a1ll_2.iccount, &i__1, "In \"AN\", file " - "name must be in quotes!", (ftnlen)128, (ftnlen)37) - ; - stop1_(); - } - a1ll_2.iccount = 128; - } else if (*(unsigned char *)durq == 'T') { - comnvst_1.cstuplet = TRUE_; - } else if (*(unsigned char *)durq == 'R') { - -/* Get full name of normal include file; must occupy remainder of line */ - - i__1 = a1ll_2.iccount; - getpmxmod_(&c_false, lineq + i__1, 128 - i__1); - a1ll_2.iccount = 128; - } else if (*(unsigned char *)durq != ' ') { - 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. */ -/* <>???? */ - -/* 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 */ - - 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 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/pmxab.c b/Build/source/utils/pmx/pmx-2.6.17/pmxab.c new file mode 100644 index 00000000000..763d8505f50 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.17/pmxab.c @@ -0,0 +1,37856 @@ +/* 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 . */ + + + +/* 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 / */ +/* because it was screwing up linux-compiled versions */ +/* Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) */ +/* 2.616 (111110) */ +/* Allow hairpins to span multiple notes groups (gulps). */ +/* 2.615+ (110810) */ +/* Fix midi when some instruments are transposed, by subtracting */ +/* iTransAmt(instno(iv)) from pitch values sent to via addmidi in */ +/* make2bar.for (for main notes) and docrd (for chord notes) */ +/* 2.615 (110725) */ +/* Fig bug with size-setting (in topfile) when instrument has >1 staves */ +/* 2.615 (110724) */ +/* Make AS[0|-|s|t]... really set sizes */ +/* 2.614 */ +/* Mod notex.for to fix Terry's bug with raised dotted rests (caused */ +/* by double-hboxing). */ +/* 2.613 */ +/* Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. */ +/* 2.612 */ +/* Enhance AS to allow s or t for smallsize or tinysize */ +/* 2.611 */ +/* Error trap for "D" before any notes in a block. */ +/* 2.610 */ +/* Instrument-wise key changes and transposition (incomplete) */ +/* 2.603 */ +/* 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors */ +/* following reading in an include file. */ +/* 101121 Added some error messages in g1etset.for setup data */ +/* 2.602 */ +/* Correct slur indexing in linebreakslurs. */ +/* Account for comment lines in line count for error messages */ +/* 2.601 */ +/* Bug fix: allow 24 slurs with graces */ +/* 2.60 Changes made make it really big */ +/* increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o */ +/* major reprogramming, and 16 may also be a problem (icmm) */ +/* nm=24 (voices) done */ +/* 24 slurs done */ +/* 24 simultaneous beams (Replace index 24 by 0, so get 0-23) */ +/* bufq*131072 (gfortran only) */ +/* getarg syntax (gfortran only) */ +/* 2.523+ */ +/* Fix voice numbering for normal dynamics and text dynamics */ +/* 2.523 */ +/* Version of bigpmx first posted to Hiroaki's web site. */ +/* 2.522 */ +/* 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. */ +/* With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. */ +/* 5/13/10 Fix log2 function */ +/* 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. */ +/* 2.521+ */ +/* 091025 Enable dotting 2nd part of linebreak slur or tie. */ +/* To adjust barno height due to linebreak slur, use \bnrs instead of */ +/* explicitly redefining \raisebarno (pmxb) */ +/* 2.521 */ +/* Bugfix */ +/* 2.520 */ +/* 090519 Enable ligfonts (special figured bass characters) */ +/* 2.519 */ +/* Fix another bug which kept \sk from being output so misaligned some notes. */ +/* 2.518 */ +/* Fix bugs: referencing fig data, char declaration for member of */ +/* common/comfig/ */ +/* 2.517 */ +/* Allow figures in voice 1 + any one other. */ +/* 2.516 */ +/* Allow figures in voice #2 */ +/* 2.515+ to do: Change manual and activate rule against clef change in voice #2. */ +/* 2.515 */ +/* 071222 Changes in getnote to allow auto forced beams to start anywhere. */ +/* 071206 In make2bar, shift fermataup7 to left over centered pause. */ +/* 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line */ +/* staff (it was screwing up vertical justification). */ +/* n34 for tweaks to midi durations of quarter note septuplets. */ +/* To do: In ref250.tex, the tables where 's,t,)' is explained, the line */ +/* [+,- i] ... Vertical adjustment of the start of second segment */ +/* should it be replaced by */ +/* [s +,- i] ... Vertical adjustment of the start of second segment */ +/* 2.514 */ +/* Changes in make2bar to get horizontal spacing right when normal grace */ +/* follows after grace */ +/* Changes in dograce to get octaves right for any material entered inside */ +/* \gaft, which shields transpose register changes from the outside world. */ +/* 2.513 */ +/* In make1bar, near end, for forced beams starting with a rest, copy hgt and */ +/* slope tweaks to ALL notes after first, not just the second one, so if */ +/* there's more than one rest at start the tweaks are still observed. */ +/* In beamid and beamend, add stand-alone triply-flagged notes for xtups. */ +/* 2.512 */ +/* Near end of pmxb, fix error trap to allow redundant 'RD' */ +/* Enable multiplicity down-up '][' within xtup. */ +/* 2.511 */ +/* Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by */ +/* adjusteskz as in bar 7 of barsant. */ +/* 2.510a */ +/* Test: remove restriction on tempo changes in MIDI macros */ +/* Send to CM for beta testing. */ +/* 2.509+ */ +/* To do: Correct manual on AS. "-" is for smaller staves. */ +/* 2.510 */ +/* Forgot to declare litq, voltxtq as character in subroutine getgrace */ +/* 2.509 */ +/* Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) */ +/* 2.508 */ +/* Allow graces in xtups. New subroutine getgrace. */ +/* 2.507 */ +/* To do: Raise/lower figures. */ +/* To do: Add 24, 29 to list of musicsizes in manual */ +/* New sub adjusteskz to account for ask's when computing lengths of */ +/* brackets for unbeamed xtups, slopes and horizontal posn's of number */ +/* Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags */ +/* Add look-left option for keyboard rests, "L" in rest command, set iornq(30) */ +/* 2.506 */ +/* Fix bug with AK, when simultaneous rests have same duration, use defaults. */ +/* 2.505 */ +/* Keyboard rests AK */ +/* 2.504 */ +/* Space after normal grace: option X[n] */ +/* Fixed og when nv .ne. noinst, by using sepsymq instead of '&' */ +/* (To do) length of xtup bracket when there is added non-collision space. */ +/* Trap musicsize if .ne. 16,20,24,29. */ +/* 2.503 */ +/* Enable arpeggio left shift with ?-x */ +/* To do: In manual, arpeggio over 2 staves. */ +/* Allow musicsize of 24 and 29. Had to define meter font size explicitly, */ +/* also change font size for text dynamics, but not much else so far. */ +/* Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn */ +/* was called, causing error in printing replacement number. */ +/* 2.502 */ +/* Incorporate Dirk Laurie's patch to use { , } , for ties. */ +/* Figure height adjustment: append +[n] */ +/* Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) */ +/* 2.501 */ +/* Readjust horizontal offset back to .8 in LineBreakTies */ +/* Fix zero-subscript (iudorn) in putorn */ +/* 2.50 */ +/* Increase number of text-dynamics (dimension of txtdynq) per block */ +/* from 12 to 41. */ +/* Slur option n to override altered default curvature. */ +/* Allow default ps slur curvature tweaks with Ap+/-c */ +/* 2.416 */ +/* Increase length of textdynq from 24 to 128 */ +/* (Todo) Add comment in manual about blank lines at end. */ +/* Configuration file: Define subroutine getpmxmod, check path in environment */ +/* variable pmxmoddir, check existence, read lines into bufq after setup. */ +/* Increase dimension on idynn in dodyn from 4 to 10 for max number */ +/* of marks in a bar */ +/* Increase allowable # of lines from 2000 to 4000. */ +/* (To do) Replace definition of \liftpausc per Olivier. */ +/* (To do) Fix extraneous error message if RD is placed at very end. */ +/* 2.415 */ +/* Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt */ +/* instead of redefining \xnum. Change font used to \smallfont (as for */ +/* normal xtups, */ +/* Allow slur to start on rest. */ +/* 2.414 */ +/* Correct bug in crdacc when adding accidental to boundary causes number of */ +/* segments to decrease */ +/* Special rule for 3-accidental chords: If no 2nds, place them in order */ +/* top, bottom, middle. */ +/* 2.413 */ +/* Correct bugs in chordal accidentals, related to left-shifted noteheads */ +/* (a) Special problems with downstem when main note needs shifting */ +/* (b) Assign 0 rank to boundary segs due to left-shifted noteheads */ +/* 2.412 */ +/* Change default horiz shift of start of seg 2 of linebreak slurs: */ +/* -.7 for slurs, -1.2 for ties, */ +/* Use height of start of seg 1 slur itself for end of 1 and start of 2. */ +/* 2.411 */ +/* "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. */ +/* "s" option in start of slur/tie as precursor to vert/horiz tweaks for end */ +/* of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. */ +/* With "Apl", curvature adjustments on starting slur command apply to seg 1, */ +/* those on ending command to seg 2. */ +/* 2.410 */ +/* "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine */ +/* \xnum, \unbkt, \ovbkt. */ +/* "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is */ +/* flag, mult(5-9) is tweak value+16 */ +/* 2.409 */ +/* Bugfix in docrd for MIDI: Use original pitch in case main/chord were */ +/* switched due to 2nds. */ +/* Remove "o" from error message for "A" command. */ +/* New syntax: optional instrument number separator ":" in movement */ +/* break command to precede a 2-digit instrument. */ +/* Conditional output formats for \setname at movement break to allow */ +/* instrument numbers >9. */ +/* Bugfix in coding to raise barno due to slur over line break (pmxb) */ +/* Move date/version data statement in pmxab to a better place. */ +/* 2.408 */ +/* Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). */ +/* Bug fix in \liftPAusep in notex.for and in pmx.tex */ +/* Character variables for version and date */ +/* For up-stem single graces slurred to down-stem, shift slur start left by */ +/* 0.8 so slur doesn't get too short. */ +/* Initialize and slide mult, same as other full-program variables in /all/. */ +/* 2.407 */ +/* Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, */ +/* 2.406 */ +/* Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing */ +/* equalization). */ +/* Put dimensions of double sharps and flats in crdacc (for chords). */ +/* Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' */ +/* Use only first 4 bits of mult for multiplicity+8, so rest can be used */ +/* for other stuff. */ +/* Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. */ +/* 2.405: Not published but saved for safety. */ +/* Option Aph to write \special{header=psslurs.pro} top of each page, so */ +/* dviselec will work OK. */ +/* 2.404 */ +/* Allow slur to end on rest, but not start on a rest. Efaults height */ +/* of ending is default height of start (before any automatic or user- */ +/* defined djustments). User may adjust height as normal from default. */ +/* 2.403 */ +/* Bugfix: turn off repeated beaming patterns.at end of non-last voice. */ +/* 2.402 */ +/* Automatic repeated forced beams. Start with "[:" End with next explicit */ +/* forced beam or end of input block. */ +/* Increase # of forced beams per line of music per input block from 20 to 40 */ +/* 2.401 */ +/* Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. */ +/* Makes 1st part normal shape, and starts 2nd part a little further left. */ +/* Enable arpeggios in xtuplets. Had to make time itar(narp) a real. */ +/* 2.40 */ +/* Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. */ +/* Fix non-ps-slur input to \midslur (third signed integer). Do not reverse */ +/* sign for down-slurs. */ +/* 2.359 */ +/* Add error exit subroutine stop1 to make exit status g77-compatible.. */ +/* Absolute octave on xtup chord note was 2 octave too high, fixed in getnote */ +/* Fermata on vertically shifted rest: special trap in putorn() to set height. */ +/* Correct multiple grace note spacing for small staves (in dograce, */ +/* define wheadpt1 depending on staff size) */ +/* 2.358 */ +/* Allow curvature corrections at start of postscript slur, in dopsslur() */ +/* Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust */ +/* Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] */ +/* Make t[ID] act like s[ID]t, most mods in spsslur(). */ +/* Add spsslur() to read in data for ps slurs, call from getnote. */ +/* In beamstrt, save args for SetupB in common comipb to save them for */ +/* 2nd call when xtup starts with rest */ +/* Add spacing for ornament ")" as if it were accidental, in make2bar(). */ +/* Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() */ +/* Horiz. shift start of ps grace slur, 2 places in dograce(). */ +/* Horiz shift end of grace slur in endslur() */ +/* Make st slurs into postscript ties. Separate subroutine dopsslur(), */ +/* Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) */ +/* Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. */ +/* 2.357a */ +/* Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote */ +/* 2.357 */ +/* Increase dimension for # of lit TeX strings from 52 to 83. */ +/* Allow blank rest in middle of xtuplet. Only mods in g*etnote(). */ +/* 2.356 */ +/* Increased some dimensions from 30 to 40 to allow up to 40 pages. */ +/* In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). */ +/* Fix parsing of "f,h,H,HH" in sslur. */ +/* Fix bug with cdot, note-level for slur termination (in getnote) */ +/* 2.355 */ +/* Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], */ +/* n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues */ +/* Make midi recognize ps ties in doslur. */ +/* Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote */ +/* to get octave right. */ +/* 2.354 */ +/* With postscript slurs, make t-slurs real ties by inserting replacement */ +/* macros \tieforisu, etc, defined in pmx.tex */ +/* Check for open cresc or decresc at end of input block, using list[de]cresc */ +/* Hairpin syntax conditional on postscript slurs. Backup to fill in start */ +/* level, using new backfill(...). Separate height tweaks for */ +/* start and finish. */ +/* 2.353 */ +/* K-0+n to transpose by half step (rather than just change key) */ +/* Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of */ +/* \mbrest's */ +/* Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end */ +/* of input block before movement break, and at start of block after */ +/* movement break, using \newmovement rather than \setzalaligne, since */ +/* former already redefines \stoppiece. In second case, set rptfg2='z'. */ +/* Make clefq(nm) common between pmxb and getnote; change references in */ +/* getnote at 'M' to array elements, setting all new clefs as you go. */ +/* 2.352 */ +/* Remove \parskip redefinition from pmx.tex; write it into TeX file when */ +/* "Ae" is invoked. */ +/* Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine */ +/* \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', */ +/* translate them thru mapping to (1,4,5,6) as \midslur params, then let */ +/* \psforts translate them back to ps slur macors. */ +/* 2.351 */ +/* Number slurs from 0 up instead of 11 down, anticipating postscript slurs. */ +/* Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. */ +/* Increase length of basenameq to 44 characters everywhere. */ +/* Increase dimension of mcpitch (midi-chord-pitch) to 20. */ +/* Set default systems per page to 1 if nv>7 */ +/* In pmxb, move place where isystpg is reset to 0, so that \eject gets */ +/* written when there is just one system per page. */ +/* 2.35 */ +/* Cautionary accidentals with 'c' anywhere in note symbol. */ +/* NEW pmx.tex with \resetsize to set size to normal or small depending on */ +/* current \internote. Used with new coding in dograce() to get right */ +/* new size in case user has \setsize'ed some lines to \smallvalue. For */ +/* \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. */ +/* Affects pmx.tex. */ +/* Continuation figure with fractional length. May now mix with other figures. */ +/* If another figure follow Cont-fig, separate with colon. */ +/* 2.342 */ +/* Bugfix in getnote to recognize relative octave shift in grace at start of */ +/* input block. */ +/* In make2bar, initialize islhgt=0 earlier than before (possible solution */ +/* to Suse g77 compile problem that I could not reproduce).. */ +/* Bugfix in beamstrt & beamn1 for r2x6 c4D d d d */ +/* 2.341 */ +/* Syntax check: Forced page break page number must be > than previous. */ +/* Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. */ +/* 2.34 */ +/* New pmx.tex with redefined liftpausc */ +/* Bug fix with dotted, non-beamed xtups. */ +/* 2.332 */ +/* Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. */ +/* Allow arbitrary pos. input to W in g1etnote and getnote. */ +/* 2.331 */ +/* Bug-fix in dodyn(..): typo on length of arg of txtdyn */ +/* 2.33 */ +/* Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() */ +/* 2.321 */ +/* Rescale accidental shifts. Still use 7 bits but now map (0,127) */ +/* onto (-1.,5.35) */ +/* Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups */ +/* 2.32 (Noticed after posting) */ +/* Prohibit "/" as figure. */ +/* 2.32 (Posted) */ +/* Tidied up accidentals in chords, do spacing. */ +/* Still to do: */ +/* check for "(" on chord notes in spacing algo */ +/* small accids */ +/* double accids */ +/* autoshift slurs */ +/* 2.310 */ +/* Extra call to precrd ahead of spacing chk, and single-note crd/acc */ +/* shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. */ +/* 2.309 */ +/* Alternate algo for accid shifts in chords. */ +/* 2.308 */ +/* Auto horiz. notehead shifting added to precrd. */ +/* 2.307 */ +/* Auto shifting of multiple accidentals in chords. */ +/* "Ao" in main chord note to keep accidentals in order. Set nacc(28). */ +/* If there are any manual main or chord note shifts, then */ +/* If any manual shift is preceded by "A" then */ +/* 1. Auto-shifting proceeds */ +/* 2. "A"-shifts add to autoshifts */ +/* 3. non-"A" shifts are ignored! */ +/* Else (>0 man shifts, none has "A") */ +/* No auto-ordering, No autoshifts, */ +/* End if */ +/* End if */ +/* 2.306 */ +/* Initialize legacy note level to middle C in case user forgets to set */ +/* octave. */ +/* Shift xtup note? */ +/* Shift in elemskips rather than noteheads? */ +/* 2.305 */ +/* Stop pmxb from multiple endvolta's at start of new page. */ +/* 2.304 */ +/* "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on */ +/* for multiple notes in the voice, "S:" last shortened note. */ +/* 2.303 */ +/* vshrink stuff all OK? Description is in pmxb. */ +/* 2.302 */ +/* Toggle vshrink with "Av". vshrink normally kicks in when \interstaff */ +/* hits 20. This still needs work. */ +/* Add " /" to last line if last char is not % or /. */ +/* 2.301 */ +/* Check in beamn1 for single note before multiplicity down-up. */ +/* allow '.PMX' as well as '.pmx' */ +/* 2.299 */ +/* Correct typo in pmxb involving PMXbarnotrue. */ +/* Replacement printed number for xtup: Unsigned integer after 'n' after 'x' */ +/* Minor upgrade parsing xtuplet options 'x...' */ +/* Correct dimension of nxtinbm in make2bar. */ +/* 2.298 */ +/* Account for doubled xtup notes in subroutine getx (user-defined spaces), */ +/* by adding ndoub as an argument.. */ +/* 2.297 */ +/* Created and solved compiler problem. Put drawbm(NM) in its own common. */ +/* Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar */ +/* when \centerbar is used. */ +/* Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX */ +/* use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. */ +/* 2.296 */ +/* Correct printed numbers for forced beams with multiple xtups. For each beam */ +/* make list in setupb by voice of eloff (h-offset) and mtupv (printed #) */ +/* Increase lengths of jobname and infileq by 20 characters */ +/* Enable whole notes and breves as 1st or last note of xtup in beamn1 and */ +/* beamend, and wholes in beamid. */ +/* 2.295 */ +/* Midi balance Ib[n1]:[n2]:...[nn] */ +/* Single-slope beam groups [...]-[...] */ +/* Trap "i" unless after accidental (main notes, xtups, chord notes) */ +/* 2.294 */ +/* Unequal xtups with "D" to double a note in an xtup. */ +/* As above, "F" will (a) increase multiplicity by 1 for marked note and next */ +/* one and (b) add a dot to the first one. */ +/* Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on */ +/* when "." is encountered, then correcting beam start time.(end of getnote) */ +/* MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... */ +/* 2.293 */ +/* Check for single notes spanning bar lines. */ +/* Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup */ +/* must be set in make2bar since beamstrt is not called, fixing problem with */ +/* dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix */ +/* problem when >2 staves. */ +/* Add nodur to args of dodyn, so can check if stemless and avoid height tweak */ +/* Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak */ +/* 2.292a */ +/* Undo syntax check for Type 2 or 3 TeX string starting in column 1. */ +/* Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! */ +/* 2.292 */ +/* Allow comments in xtuplets */ +/* Enable multiple octave jumps in grace notes. */ +/* Allow dynamics in xtuplets. */ +/* Fix bug in getdyn searching for end of text string (correct length of lineq */ +/* to 128) */ +/* Fix bug in dodyn, must ignore horiz. interaction tweak for */ +/* user-text (idno = 0) */ +/* Syntax check for Type 2 or 3 TeX string starting in column 1 */ +/* (NOTE: later undone!) */ +/* Syntax check for page number > npages at forced line break. */ +/* 2.291 */ +/* Fix error in AS command (accid spacing for small systems), making only */ +/* one spec per staff, nv total. */ +/* Stop using MIDI channel 10 */ +/* 2.29 */ +/* Fix error in console output format for # of bytes used in MIDI file. */ +/* Fix bug in dograce so no space is added between grace and main note when */ +/* there is a MIDI-only accidental. */ +/* Fix bug so oes?+4 works. It was too ugly to explain. */ +/* ...Different ways of storing accidental specs on input and output. */ +/* No longer zap \writezbarno in special situations. */ +/* Fix bug in dyntxt level on rest */ +/* Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. */ +/* Activate with Ae. (Maybe later could input alternate values for */ +/* \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 */ +/* in the page, and \endeq on 1st note of next-to-last line in page. */ +/* 2.28 */ +/* Flip direction of forced beam "[f..." */ +/* Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) */ +/* Fix bug in sliding ip's for txtdyn's */ +/* In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) */ +/* 2.27 */ +/* Comment out lines in dodyn checking number of dynamic marks found. Voice */ +/* order may not be monotonic if two lines on a staff. */ +/* Literal dynamic: D"[text]" */ +/* 2.26 */ +/* Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, */ +/* increasing dimension of idynn to 4 to allow 4 symbols on same note. */ +/* Increase voltxtq length from 10 to 20. */ +/* AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough */ +/* accounting for ast's is done by defining effective headwidth */ +/* whead1 in makebar2 to be 0.8*whead. */ +/* 2.25 */ +/* Fix logic bug with sepsym's when # of instruments changes. */ +/* Slight increases in default offsets for hairpin starts after "p" */ +/* 2.24 */ +/* Hairpins D< or D> as toggle. */ +/* Many automatic position tweaks for letter-group dynamics and hairpins. */ +/* 2.23 */ +/* Continued rhythmic shortcuts: space followed by "." or "," */ +/* 2.22 */ +/* In call to doslur, change tno(...) to tnote(...). This was only */ +/* used when checking to slurs per stem directions, and should have been */ +/* the note duration all along. */ +/* MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. */ +/* Use "i" anywhere in note symbol. */ +/* 2.21 */ +/* Increase from 20 to 30 dimensions for movement breaks and midi sections. */ +/* Fix out-of-order declarations per mutex comments */ +/* Add "Bad error" and "Kluging" messages to log file. */ +/* 2.197 */ +/* add /comips/ to save tie-check midi variables */ +/* For spacing of clef changes at start of input block, changed integer time */ +/* lastnodur to prevtn, so it works with xtups. Possible incompatibility! */ +/* 2.196 */ +/* Fix Ickbug with time check in ncmid() */ +/* Interchange \fermataup7 and \pausec to get proper alignment */ +/* Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. */ +/* Add defn's of \hsp, \hspp to pmx.tex */ +/* Fix pre-slurs on xtup chord notes. */ +/* Fixed raised PAuse, define \liftPAuse */ +/* Replace \zbreve\sk with \breve. */ +/* Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what */ +/* about "o" and 1 as shorthand for 16???? Search for "Kluge" */ +/* Added "vo" (voice) as MIDI instrument 55 */ +/* Allow 3-digit page numbers (search for "toppageno") */ +/* Fix bug caused by prior fix (cancelling accid after bar line was ignored). */ +/* Fix double accids in chords */ +/* 2.194 */ +/* Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if */ +/* block. */ +/* Add meter to MIDI file with every pause */ +/* Purify FORTRAN? */ +/* 2.193 */ +/* Increased # of in-line TeX strings from 36 to 52. */ +/* Fix entry of # of bytes in header of tempo/meter/key track to allow >255. */ +/* 2.191 */ +/* Event track: Tempos, meters, keys all together. Data in comevent */ +/* 2.15 */ +/* Pretty good midi capability. Still no attention to slurs on chord notes. */ +/* 2.11 */ +/* 11 Dec 99 c rm1 */ +/* 11 Dec 99 "oes?", "oe?" */ +/* 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes */ +/* 11 Dec 99 Error message for shifted, repeated ornaments. */ +/* 2.10 (Version 2.1) */ +/* Fix bug with lowdot and xtuplets */ +/* 2.09 */ +/* Fix bug with multiple ornament heights over beams, when one is . or _ */ +/* Error message from pmxa if rest on last note of xtup. */ +/* Enable 12 slurs. */ +/* Reinstate multiple rests at start of xtup. */ +/* 2.07 */ +/* Combine consecutive type-1 TeX strings. */ +/* \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. */ +/* Fixed breve chord notes in docrd */ +/* Check irest(28) as well as vxtup when setting nodur for chord notes, since */ +/* vxtup isn't set until 1st *main* note in xtup */ +/* Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. */ +/* 2.06+ */ +/* Make deterministic the beam slope calculation when there are an even # of */ +/* slopes in list and middle two are equal magnitude but opposite sign. */ +/* pmxa Trap for "o:" before 1st note in block */ +/* Partial bug fix for 64th notes in xtuplets. */ +/* Make ixrest a vector, since with new time scheme may not finish xtup in */ +/* same notes block. */ +/* Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) */ +/* 2.06 */ +/* Account for changes in nv when computing \interstaff. Add a counter */ +/* nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever */ +/* setting isysflb(iflb). Note nv can only change at a forced line break. */ +/* Note also, iflb starts at 0! */ +/* 2.05 */ +/* Automatic start of new notes group with part 2 of staff-jump beam */ +/* In make1bar, set irest bit 29 of lowest-voice note at same time, */ +/* use as flag when making notes groups. */ +/* For now, remove dummy blank line at end...it zaps terminal repeats. */ +/* 2.02 */ +/* Fixed slur-counting bug for multiple, slurred, aftergraces. */ +/* 2.01 */ +/* Increase to ask(1400) */ +/* Increase max forced page breaks to 18 */ +/* Define pausc for centered pause */ +/* 2.0a */ +/* Insert dummy blank line at very end to handle input files w/o terminal CR-LF */ +/* pmx03r */ +/* Option m[n] in S symbol to change musicsize (for parts) */ +/* Double dotted rests now work. */ +/* Write file name to log file */ +/* Check existence of input file */ +/* Allow 24-char jobname, may end with ".pmx" */ +/* Comment out time stuff */ +/* Replace 3-argument getarg with 2-argument + iargc */ +/* Fix bug with negative noinst due to nint<=int replacement */ +/* move lovation of iv in isdat1 to allow iv>7. */ +/* Set nm=12 */ +/* pmx03q */ +/* replace int(x+.001) with nint(x) */ +/* Write TeX file name to screen and to pml. */ +/* Replace char(...) with chax(...) to sovle msdev bug. */ +/* Bug fix: macro terminations when M is on a line by itself. */ +/* Bug fix: don't accumulate space for XS in pmxa. */ +/* Streamline Macros: use pointers to bufq instead of scratch files */ +/* pmx03p */ +/* Store input file in single character array bufq. */ +/* lbuf(i)*2 is length of line i */ +/* ipbuf is position just before next line to be read. */ +/* pmx03 */ +/* Optimize read/writes */ +/* pmx02 */ +/* Fix line count (for errors) when there are saved macros */ +/* pmx01 */ +/* In optimize mode, open/close macros (Watch out for residual zz files!) */ +/* Command line input */ +/* Option Ao to optimize, otherwise normal processing */ + +/* cccccc */ + +/* immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing */ +/* nmidsec section starts and stops based on PLAYING macros (not recording). */ + +/* cccccccccccccccccccccccc */ + + +/* cccccccccccccccccccccccc */ +/* itstart = mytime() */ + s_copy(comver_1.versionc, version, (ftnlen)5, (ftnlen)5); + +/* Initialize midi parameters */ + + commmac_1.gottempo = FALSE_; + commidi_1.ismidi = FALSE_; + commidi_1.debugmidi = FALSE_; + commidi_1.relacc = FALSE_; + commmac_1.mmacrec = FALSE_; + commmac_1.nmidsec = 1; + commidi_1.mgap = 10; + comevent_1.miditime = 0; + comevent_1.lasttime = 0; + commidi_1.nmidcrd = 0; + comslm_1.nusebl = 0; + commidi_1.notmain = FALSE_; + for (ivx = 1; ivx <= 24; ++ivx) { + commidi_1.twoline[ivx - 1] = FALSE_; + commidi_1.midinst[ivx - 1] = 6; + commvel_1.midivel[ivx - 1] = 127; + commvel_1.midibal[ivx - 1] = 64; + commvel_1.miditran[ivx - 1] = 0; +/* L3: */ + } + for (icm = 0; icm <= 24; ++icm) { + commidi_1.imidi[icm] = 0; + commidi_1.restpend[icm] = FALSE_; + commidi_1.trest[icm] = 0.f; + comslm_1.levson[icm] = 0; + comslm_1.levsoff[icm] = 0; + comslm_1.slmon[icm] = FALSE_; + comslm_1.naccbl[icm] = 0; + comdiag_1.n69[icm] = 0; + comdiag_1.n34[icm] = 0; + commmac_1.msecstrt[icm] = 1; +/* L12: */ + } + +/* End of midi parameter initialization */ + + commus_1.musize = 0; + optimize = FALSE_; + numargs = iargc_(); + if (numargs == 0) { + s_wsle(&io___10); + do_lio(&c__9, &c__1, "You could have entered a jobname on the comman" + "d line,", (ftnlen)53); + e_wsle(); + s_wsle(&io___11); + do_lio(&c__9, &c__1, " but you may enter one now:", (ftnlen)32); + e_wsle(); + s_rsfe(&io___12); + do_fio(&c__1, jobname, (ftnlen)44); + e_rsfe(); + numargs = 1; + } else { +/* call getarg(1,jobname,idum) ! May need to replace this w/ next line */ + getarg_(&c__1, jobname, (ftnlen)44); + } +L10: + ljob = lenstr_(jobname, &c__44, (ftnlen)44); + if (ljob > 44) { + s_wsle(&io___15); + do_lio(&c__9, &c__1, "Jobname is too long. Try again.", (ftnlen)31); + e_wsle(); + stop1_(); + } else if (ljob == 0) { + s_wsle(&io___16); + do_lio(&c__9, &c__1, "No was jobname entered. Try again.", (ftnlen)34) + ; + e_wsle(); + stop1_(); + } else if (numargs == 2) { + if (ljob == 2 && s_cmp(jobname, "-o", (ftnlen)2, (ftnlen)2) == 0) { + optimize = TRUE_; +/* call getarg(2,jobname,idum) ! May need to replace this w/ next line */ + getarg_(&c__2, jobname, (ftnlen)44); + numargs = 1; + goto L10; + } else { + s_wsle(&io___17); + do_lio(&c__9, &c__1, "Illegal option on command line", (ftnlen)30) + ; + e_wsle(); + stop1_(); + } + } + +/* Strip ".pmx" if necessary */ + +/* Computing MAX */ + i__1 = i_indx(jobname, ".pmx", (ftnlen)44, (ftnlen)4), i__2 = i_indx( + jobname, ".PMX", (ftnlen)44, (ftnlen)4); + ndxpmx = max(i__1,i__2); + if (ndxpmx > 0) { + s_copy(jobname, jobname, (ftnlen)44, ndxpmx - 1); + ljob += -4; + } + +/* Check for existence of input file */ + +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".pmx"; + s_cat(infileq, a__1, i__3, &c__2, (ftnlen)47); + ioin__1.inerr = 0; + ioin__1.infilen = 47; + ioin__1.infile = infileq; + ioin__1.inex = &fexist; + ioin__1.inopen = 0; + ioin__1.innum = 0; + ioin__1.innamed = 0; + ioin__1.inname = 0; + ioin__1.inacc = 0; + ioin__1.inseq = 0; + ioin__1.indir = 0; + ioin__1.infmt = 0; + ioin__1.inform = 0; + ioin__1.inunf = 0; + ioin__1.inrecl = 0; + ioin__1.innrec = 0; + ioin__1.inblank = 0; + f_inqu(&ioin__1); + if (! fexist) { + ioin__1.inerr = 0; + ioin__1.infilen = ljob + 4; +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".PMX"; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); + ioin__1.infile = ch__1; + ioin__1.inex = &fexist; + ioin__1.inopen = 0; + ioin__1.innum = 0; + ioin__1.innamed = 0; + ioin__1.inname = 0; + ioin__1.inacc = 0; + ioin__1.inseq = 0; + ioin__1.indir = 0; + ioin__1.infmt = 0; + ioin__1.inform = 0; + ioin__1.inunf = 0; + ioin__1.inrecl = 0; + ioin__1.innrec = 0; + ioin__1.inblank = 0; + f_inqu(&ioin__1); + if (! fexist) { + s_wsle(&io___21); +/* Writing concatenation */ + i__3[0] = 17, a__1[0] = "Cannot find file "; + i__3[1] = 47, a__1[1] = infileq; + s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)64); + do_lio(&c__9, &c__1, ch__2, (ftnlen)64); + e_wsle(); + stop1_(); + } else { +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".PMX"; + s_cat(infileq, a__1, i__3, &c__2, (ftnlen)47); + } + } + +/* Open a log file */ + + o__1.oerr = 0; + o__1.ounit = 15; + o__1.ofnmlen = ljob + 4; +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".pml"; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); + o__1.ofnm = ch__1; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); +/* Writing concatenation */ + i__4[0] = 21, a__2[0] = "This is PMX, Version "; + i__4[1] = 5, a__2[1] = version; + i__4[2] = 2, a__2[2] = ", "; + i__4[3] = 9, a__2[3] = date; + s_cat(ch__3, a__2, i__4, &c__4, (ftnlen)37); + printl_(ch__3, (ftnlen)37); + ljob4 = ljob; +/* Writing concatenation */ + i__3[0] = 8, a__1[0] = "Opening "; + i__3[1] = 47, a__1[1] = infileq; + s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)55); + printl_(ch__4, (ftnlen)55); + o__1.oerr = 0; + o__1.ounit = 18; + o__1.ofnmlen = 47; + o__1.ofnm = infileq; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + +/* Copy input file into common buffer */ + + inbuff_1.ipbuf = 0; + truelinecount_1.linewcom[0] = 1; + for (inbuff_1.ilbuf = 1; inbuff_1.ilbuf <= 4000; ++inbuff_1.ilbuf) { + ncomments = 0; +L14: + i__1 = s_rsfe(&io___24); + if (i__1 != 0) { + goto L9; + } + i__1 = do_fio(&c__1, lnholdq, (ftnlen)128); + if (i__1 != 0) { + goto L9; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L9; + } + inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) lenstr_(lnholdq, & + c__128, (ftnlen)128); + if (inbuff_1.lbuf[inbuff_1.ilbuf - 1] == 0) { + +/* Blank line. Make it a single blank with length 1 */ + + inbuff_1.lbuf[inbuff_1.ilbuf - 1] = 1; + s_copy(lnholdq, " ", (ftnlen)128, (ftnlen)1); + } + +/* Now line has at least one non blank character. Check for comment */ +/* As of Version 260, do not copy comments into bufq */ +/* But need to count %'s for error messaging */ +/* if (lnholdq(1:1).eq.'%') go to 14 */ + if (*(unsigned char *)lnholdq == '%') { + ++ncomments; + goto L14; + } + +/* When here, have counted all preceding comments and have a real line */ + + if (inbuff_1.ilbuf > 1) { + truelinecount_1.linewcom[inbuff_1.ilbuf - 1] = + truelinecount_1.linewcom[inbuff_1.ilbuf - 2] + 1 + + ncomments; + } else { + truelinecount_1.linewcom[0] = ncomments + 1; + } + if (inbuff_1.ipbuf + inbuff_1.lbuf[inbuff_1.ilbuf - 1] > 65536) { + s_wsle(&io___26); + do_lio(&c__9, &c__1, "Too many characters in file, stopping", ( + ftnlen)37); + e_wsle(); + stop1_(); + } + i__1 = inbuff_1.ipbuf; + s_copy(inbuff_1.bufq + i__1, lnholdq, inbuff_1.ipbuf + inbuff_1.lbuf[ + inbuff_1.ilbuf - 1] - i__1, (ftnlen)128); + inbuff_1.ipbuf += inbuff_1.lbuf[inbuff_1.ilbuf - 1]; +/* L8: */ + } + printl_("Too many lines in input file", (ftnlen)28); + stop1_(); +L9: + +/* Insert dummy line to handle input files w/o CR-LF at end. */ + + inbuff_1.nlbuf = inbuff_1.ilbuf - 1; +/* nlbuf = ilbuf */ +/* bufq(ipbuf+1:ipbuf+3) = ' / ' */ +/* lbuf(nlbuf) = 3 */ + cl__1.cerr = 0; + cl__1.cunit = 18; + cl__1.csta = 0; + f_clos(&cl__1); + i__1 = maxit; + for (numit = 1; numit <= i__1; ++numit) { + if (optimize) { + printl_("Starting an iteration", (ftnlen)21); + } + +/* When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. */ +/* Otherwise, nbars0 is the input */ +/* When islast=.false., pmxb only returns poe's, otherwise does whole job */ + + pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars0, &optimize, (ftnlen) + 44); + if (! optimize) { + if (commidi_1.ismidi) { + +/* Set up channel numbers for midi. */ + + commidi_1.numchan = 0; + for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) { + if (commidi_1.twoline[a1ll_1.iv - 1]) { + commidi_1.midchan[a1ll_1.iv + 23] = commidi_1.numchan; + ++commidi_1.numchan; + } + commidi_1.midchan[a1ll_1.iv - 1] = commidi_1.numchan; + ++commidi_1.numchan; +/* L11: */ + } + +/* numchan will now be the number of channels, but max channel # is numchan-1 */ + +/* Set up velocities, balances, and midi-transpositions */ + + for (a1ll_1.iv = a1ll_1.nv; a1ll_1.iv >= 1; --a1ll_1.iv) { + if (commidi_1.twoline[a1ll_1.iv - 1]) { + commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.midivel[a1ll_1.iv - 1]; + commvel_1.midbc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.midibal[a1ll_1.iv - 1]; + commvel_1.midtc[commidi_1.midchan[a1ll_1.iv + 23]] = + commvel_1.miditran[a1ll_1.iv - 1]; + } + commvel_1.midvelc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.midivel[a1ll_1.iv - 1]; + commvel_1.midbc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.midibal[a1ll_1.iv - 1]; + commvel_1.midtc[commidi_1.midchan[a1ll_1.iv - 1]] = + commvel_1.miditran[a1ll_1.iv - 1]; +/* L13: */ + } + } + +/* TEMPORARY!!! */ + + s_wsle(&io___30); + do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7); + do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof( + integer)); + e_wsle(); + ip1 = 1; + i__2 = inbuff_1.nlbuf; + for (ilb = 1; ilb <= i__2; ++ilb) { +/* write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), */ +/* * bufq(ip1:ip1+lbuf(ilb)-1), */ +/* * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), */ +/* * k=min(3,lbuf(ilb)),1,-1) */ + ip1 += inbuff_1.lbuf[ilb - 1]; +/* L10000: */ + } + iplast = ip1 - 1; + +/* Check to see if (1) last line is "/" and (2) next to last */ +/* line is "/" */ + +/* print*,'iplast:',iplast */ +/* print*,'Last line:' */ +/* print*,bufq(iplast+1-lbuf(nlbuf):iplast) */ +/* print*,'Last char of next to last line:' */ +/* print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) */ + i__2 = iplast + 1 - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1; + if (s_cmp(inbuff_1.bufq + i__2, " /", iplast - i__2, (ftnlen)3) + == 0) { + i__2 = iplast - inbuff_1.lbuf[inbuff_1.nlbuf - 1] - 1; + if (s_cmp(inbuff_1.bufq + i__2, "/", iplast - inbuff_1.lbuf[ + inbuff_1.nlbuf - 1] - i__2, (ftnlen)1) == 0) { + s_wsle(&io___34); + do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39); + e_wsle(); + s_wsle(&io___35); + do_lio(&c__9, &c__1, "Removing last line of \"/\"", (ftnlen)39); + e_wsle(); + --inbuff_1.nlbuf; + } + } + + pmxb_(&c_true, poe0, &ncalls, &optimize); + if (commidi_1.ismidi) { + +/* Write midi file */ + + o__1.oerr = 0; + o__1.ounit = 51; + o__1.ofnmlen = ljob + 4; +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".mid"; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); + o__1.ofnm = ch__1; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + if (commidi_1.debugmidi) { + o__1.oerr = 0; + o__1.ounit = 52; + o__1.ofnmlen = ljob + 4; +/* Writing concatenation */ + i__3[0] = ljob, a__1[0] = jobname; + i__3[1] = 4, a__1[1] = ".dbm"; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)48); + o__1.ofnm = ch__1; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + } + printl_(" ", (ftnlen)1); +/* Writing concatenation */ + i__5[0] = 8, a__3[0] = "Writing "; + i__5[1] = ljob, a__3[1] = jobname; + i__5[2] = 4, a__3[2] = ".mid"; + s_cat(ch__5, a__3, i__5, &c__3, (ftnlen)56); + printl_(ch__5, ljob + 12); + writemidi_(jobname, &ljob, (ftnlen)44); + } + cl__1.cerr = 0; + cl__1.cunit = 15; + cl__1.csta = 0; + f_clos(&cl__1); + s_stop("", (ftnlen)0); + } + s_wsle(&io___37); + do_lio(&c__9, &c__1, "nlbuf: ", (ftnlen)7); + do_lio(&c__3, &c__1, (char *)&inbuff_1.nlbuf, (ftnlen)sizeof(integer)) + ; + e_wsle(); + ip1 = 1; + pmxb_(&c_false, poe0, &ncalls, &optimize); + poestats_(&nsyst, poe0, &poebar0, &devnorm0); + +/* Save initial deviation and line breaks for later comparison */ + + if (numit == 1) { + devpmx = devnorm0; + i__2 = nsyst; + for (isys = 1; isys <= i__2; ++isys) { + nbari[isys - 1] = nbars0[isys - 1]; +/* L20: */ + } + } + sortpoe_(&nsyst, poe0, ipoe); + for (iupord = nsyst; iupord >= 1; --iupord) { + isysu = ipoe[iupord - 1]; + s_wsle(&io___46); + do_lio(&c__9, &c__1, "isysu=", (ftnlen)6); + do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer)); + e_wsle(); + s_wsle(&io___47); + do_lio(&c__9, &c__1, "isysu=", (ftnlen)6); + do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof(integer)); + e_wsle(); + +/* Skip if system isysu has poe0 < avg or isysd has poe0 > avg */ + + if (poe0[isysu - 1] < poebar0) { + goto L1; + } + i__2 = nsyst; + for (idnord = 1; idnord <= i__2; ++idnord) { + isysd = ipoe[idnord - 1]; + if (isysu == isysd || nbars0[isysd - 1] == 1 || poe0[isysd - + 1] > poebar0) { + goto L5; + } + i__6 = nsyst; + for (isyst = 1; isyst <= i__6; ++isyst) { + nbars[isyst - 1] = nbars0[isyst - 1]; + if (isyst == isysu) { + ++nbars[isyst - 1]; + } else if (isyst == isysd) { + --nbars[isyst - 1]; + } +/* L2: */ + } + pmxa_(jobname, &ljob4, &isfirst, &nsyst, nbars, &optimize, ( + ftnlen)44); + pmxb_(&c_false, poe, &ncalls, &optimize); + poestats_(&nsyst, poe, &poebar, &devnorm); + if (devnorm < devnorm0) { + devnorm0 = devnorm; + poebar0 = poebar; + i__6 = nsyst; + for (isys = 1; isys <= i__6; ++isys) { + nbars0[isys - 1] = nbars[isys - 1]; + poe0[isys - 1] = poe[isys - 1]; +/* L4: */ + } + s_wsle(&io___55); + do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", ( + ftnlen)32); + do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof( + integer)); + do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof( + integer)); + do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof( + real)); + e_wsle(); + s_wsle(&io___56); + do_lio(&c__9, &c__1, "Improved with iup,idown,devnorm:", ( + ftnlen)32); + do_lio(&c__3, &c__1, (char *)&isysu, (ftnlen)sizeof( + integer)); + do_lio(&c__3, &c__1, (char *)&isysd, (ftnlen)sizeof( + integer)); + do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof( + real)); + e_wsle(); + s_wsfe(&io___57); + i__6 = nsyst; + for (isys = 1; isys <= i__6; ++isys) { + do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen) + sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___58); + i__6 = nsyst; + for (isys = 1; isys <= i__6; ++isys) { + do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen) + sizeof(integer)); + } + e_wsfe(); + sortpoe_(&nsyst, poe0, ipoe); + goto L6; + } +L5: + ; + } +L1: + ; + } + +/* If we get here, must have gone thru all switches and found nothing better, */ +/* so done! */ + + goto L7; +L6: + ; + } +L7: + s_wsle(&io___59); + do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23); + do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer)); + do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10); + do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer)); + e_wsle(); + s_wsle(&io___60); + do_lio(&c__9, &c__1, "Optimum located, numit:", (ftnlen)23); + do_lio(&c__3, &c__1, (char *)&numit, (ftnlen)sizeof(integer)); + do_lio(&c__9, &c__1, ", ncalls:", (ftnlen)10); + do_lio(&c__3, &c__1, (char *)&ncalls, (ftnlen)sizeof(integer)); + e_wsle(); + s_wsle(&io___61); + do_lio(&c__9, &c__1, "Final error:", (ftnlen)12); + do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real)); + do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16); + do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real)); + e_wsle(); + s_wsle(&io___62); + do_lio(&c__9, &c__1, "Final error:", (ftnlen)12); + do_lio(&c__4, &c__1, (char *)&devnorm0, (ftnlen)sizeof(real)); + do_lio(&c__9, &c__1, ", initial error:", (ftnlen)16); + do_lio(&c__4, &c__1, (char *)&devpmx, (ftnlen)sizeof(real)); + e_wsle(); + s_wsle(&io___63); + do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23); + r__1 = (1 - devnorm0 / devpmx) * 100.f; + do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real)); + e_wsle(); + s_wsle(&io___64); + do_lio(&c__9, &c__1, "Percentage improvement:", (ftnlen)23); + r__1 = (1 - devnorm0 / devpmx) * 100.f; + do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real)); + e_wsle(); + printl_("Initial bars/system:", (ftnlen)20); + s_wsfe(&io___65); + i__1 = nsyst; + for (isys = 1; isys <= i__1; ++isys) { + do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___66); + i__1 = nsyst; + for (isys = 1; isys <= i__1; ++isys) { + do_fio(&c__1, (char *)&nbari[isys - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + printl_("Final bars/system:", (ftnlen)18); + s_wsfe(&io___67); + i__1 = nsyst; + for (isys = 1; isys <= i__1; ++isys) { + do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___68); + i__1 = nsyst; + for (isys = 1; isys <= i__1; ++isys) { + do_fio(&c__1, (char *)&nbars0[isys - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + pmxa_(jobname, &ljob4, &c_false, &nsyst, nbars0, &optimize, (ftnlen)44); + pmxb_(&c_true, poe0, &ncalls, &optimize); +/* itend = mytime() */ +/* print*,'Elapsed time in ms:',itend-itstart */ +/* write(15,*)'Elapsed time in ms:',itend-itstart */ + cl__1.cerr = 0; + cl__1.cunit = 15; + cl__1.csta = 0; + f_clos(&cl__1); + return 0; +} /* MAIN__ */ + +/* Subroutine */ int accsym_(integer *nacc, char *acsymq, integer *lacc, + ftnlen acsymq_len) +{ + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + + /* Local variables */ + static integer iacc; + + /* Fortran I/O blocks */ + static cilist io___70 = { 0, 6, 0, 0, 0 }; + + + iacc = *nacc & 7; + if (iacc == 1) { + s_copy(acsymq, "fl", (ftnlen)3, (ftnlen)2); + *lacc = 2; + } else if (iacc == 2) { + s_copy(acsymq, "sh", (ftnlen)3, (ftnlen)2); + *lacc = 2; + } else if (iacc == 3) { + s_copy(acsymq, "na", (ftnlen)3, (ftnlen)2); + *lacc = 2; + } else if (iacc == 5) { + s_copy(acsymq, "dfl", (ftnlen)3, (ftnlen)3); + *lacc = 3; + } else if (iacc == 6) { + s_copy(acsymq, "dsh", (ftnlen)3, (ftnlen)3); + *lacc = 3; + } else { + s_wsle(&io___70); + do_lio(&c__9, &c__1, "bad accidental: ", (ftnlen)16); + do_lio(&c__3, &c__1, (char *)&iacc, (ftnlen)sizeof(integer)); + e_wsle(); + } + return 0; +} /* accsym_ */ + +/* Subroutine */ int addask_(real *taskn, real *waskn, real *elaskn, real * + fixednew, real *scaldold, real *tglp1, logical *isudsp) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + + /* Local variables */ + extern /* Subroutine */ int stop1_(void); + static integer iudsp; + + /* Fortran I/O blocks */ + static cilist io___72 = { 0, 6, 0, 0, 0 }; + + + if (*isudsp) { + +/* Find which udsp we're dealing with */ + + i__1 = comudsp_1.nudsp; + for (iudsp = 1; iudsp <= i__1; ++iudsp) { + if ((r__1 = *taskn + *tglp1 - comudsp_1.tudsp[iudsp - 1], dabs( + r__1)) < comtol_1.tol) { + goto L2; + } +/* L1: */ + } + s_wsle(&io___72); + do_lio(&c__9, &c__1, "You should note BEEE here in addask!", (ftnlen) + 36); + e_wsle(); + stop1_(); +L2: + +/* Fixednew and scaldold must not be changed, since udsp's are already included */ +/* in fsyst from pmxa, and udsp don't involve scaled space.. */ + + if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1, + comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) { + +/* Must add user-defined space to what's there already. */ + + comas1_1.wask[comas1_1.naskb - 1] += comudsp_1.udsp[iudsp - 1]; + } else { + +/* This place has no other space. */ + + ++comas1_1.naskb; + comas1_1.task[comas1_1.naskb - 1] = *taskn; + comas1_1.wask[comas1_1.naskb - 1] = comudsp_1.udsp[iudsp - 1]; + comas1_1.elask[comas1_1.naskb - 1] = 0.f; + } + } else { + +/* This is a normal space, no effect if smaller than existing space */ + + if (comas1_1.naskb > 0 && (r__1 = *taskn - comas1_1.task[max(1, + comas1_1.naskb) - 1], dabs(r__1)) < comtol_1.tol) { + +/* We already put in some space at this time */ +/* Check if new one needs more space than old one at same time */ + + if (*waskn > comas1_1.wask[comas1_1.naskb - 1]) { + --comas1_1.naskb; + } else { + return 0; + } + } + ++comas1_1.naskb; + comas1_1.task[comas1_1.naskb - 1] = *taskn; + comas1_1.wask[comas1_1.naskb - 1] = *waskn; + comas1_1.elask[comas1_1.naskb - 1] = *elaskn; + *fixednew += *waskn; + *scaldold += *elaskn; + } + return 0; +} /* addask_ */ + +/* Subroutine */ int addblank_(char *noteq, integer *lnoten, ftnlen noteq_len) +{ + /* System generated locals */ + address a__1[2]; + integer i__1[2]; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, + char **, integer *, integer *, ftnlen); + + /* Local variables */ + static char tchar[1]; + + s_copy(tchar, noteq, (ftnlen)1, (ftnlen)8); +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = " "; + i__1[1] = 1, a__1[1] = tchar; + s_cat(noteq, a__1, i__1, &c__2, (ftnlen)8); + *lnoten = 2; + return 0; +} /* addblank_ */ + +/* Subroutine */ int addfb_(integer *nfb, integer *iv, real *tnew, real *t1fb, + real *t2fb, char *ulfbq, integer *ifbadd, ftnlen ulfbq_len) +{ + static integer ifb; + + /* Parameter adjustments */ + ulfbq -= 25; + t2fb -= 25; + t1fb -= 25; + --nfb; + + /* Function Body */ + *ifbadd = 1; + ++nfb[*iv]; + for (ifb = nfb[*iv] - 1; ifb >= 1; --ifb) { + if (*tnew < t1fb[*iv + ifb * 24] - comtol_1.tol) { + t1fb[*iv + (ifb + 1) * 24] = t1fb[*iv + ifb * 24]; + t2fb[*iv + (ifb + 1) * 24] = t2fb[*iv + ifb * 24]; + *(unsigned char *)&ulfbq[*iv + (ifb + 1) * 24] = *(unsigned char * + )&ulfbq[*iv + ifb * 24]; + } else { + *ifbadd = ifb + 1; + goto L2; + } +/* L1: */ + } +L2: + t1fb[*iv + *ifbadd * 24] = *tnew; + *(unsigned char *)&ulfbq[*iv + *ifbadd * 24] = 'x'; + return 0; +} /* addfb_ */ + + + +/* Subroutine */ int addmidi_(integer *icm, integer *nolev, integer *iacc, + integer *isig, real *time, logical *rest, logical *endrest) +{ + /* Initialized data */ + + static shortint icmm[16] = { 0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16 }; + + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + + /* Builtin functions */ + integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, + char *, ftnlen), e_wsle(void), i_indx(char *, char *, ftnlen, + ftnlen); + + /* Local variables */ + static logical it1found; + static integer nsav4tie; + extern /* Subroutine */ int chkimidi_(integer *); + static char notenumq[1]; + static integer i__, j, it1; + extern integer igetvarlen_(shortint *, integer *, integer *, integer *); + static integer it2; + extern integer isetvarlen_(integer *, integer *); + static integer ion; + static shortint itk[25]; + static integer jacc, kacc, macc, ioff, isav, idur, jsav, idur1; + extern /* Subroutine */ int stop1_(void); + static integer imidt, ipsav, ipsav0, nby2on; + extern integer iashft_(integer *); + static integer nbytes; + extern /* Subroutine */ int printl_(char *, ftnlen); + static integer nby2off; + static logical eximacc; + static integer itiesav[500] /* was [5][100] */, idurvar; + + /* Fortran I/O blocks */ + static cilist io___80 = { 0, 6, 0, 0, 0 }; + static cilist io___92 = { 0, 6, 0, 0, 0 }; + + + +/* Following variables are local but must be saved. I hope they are. */ +/* (3/18/00) With g77 they are not, so add a common block here. */ + +/* integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) */ +/* data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ */ + +/* Cancel out barline accidentals if there's a rest. */ + + if (*rest) { + comslm_1.naccbl[(300 + (0 + (*icm - 0 << 2)) - 300) / 4] = 0; + } + +/* Special path to insert dummy rest at end of a section */ + + if (*endrest) { + goto L20; + } + + i__1 = commidi_1.nmidcrd; + for (ion = 0; ion <= i__1; ++ion) { + +/* check if this is only to get pitch of a chord note */ + + if (commidi_1.notmain) { + goto L6; + } + +/* check for rest */ + + if (*rest) { + +/* Will not put in a note, but must update timing */ + + if (! commidi_1.restpend[*icm]) { + +/* First rest in sequence, save the time */ + + commidi_1.restpend[*icm] = TRUE_; + commidi_1.trest[*icm] = *time; + } else { + commidi_1.trest[*icm] += *time; + } + +/* Note: code checkers don't like the above due to calling addmidi(trest(icm)) */ +/* but this only happens if rest at end of section (endrest=.true.) (called */ +/* from getmidi(), in which case these above lines are bypassed. */ + + chkimidi_(icm); + return 0; + } + +/* time tics */ + + if (commidi_1.imidi[*icm] > 0 && ion == 0) { + idur = commidi_1.mgap; + } else { + idur = 0; + } + if (commidi_1.restpend[*icm]) { + commidi_1.restpend[*icm] = FALSE_; + r__1 = commidi_1.trest[*icm] * 15; + idur += i_nint(&r__1); + } + +/* time to start of note */ + + idurvar = isetvarlen_(&idur, &nby2on); + if (nby2on > 4) { + s_wsle(&io___80); + do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.", ( + ftnlen)37); + e_wsle(); + stop1_(); + } + ++commidi_1.imidi[*icm]; + i__2 = nby2on; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* imidi points to cell before highest (leftmost) byte. Start with lowest byte */ +/* at far right, fill in backwards */ + + commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2on - i__) * + 25 - 25] = (shortint) (idurvar % 256); + if (nby2on > 1) { + idurvar /= 256; + } +/* L2: */ + } + commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2on - 1; + +/* Note-on signal */ + + ++commidi_1.imidi[*icm]; +/* mmidi(icm,imidi(icm)) = 9*16+icm */ + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) ( + icmm[*icm] + 144); + +/* Entry point for chord note pitch determination */ + +L6: + +/* Get midi pitch. On chord iteration, only do this first time (main note), */ +/* since pitch was already computed for nonmain chord notes. */ + + if (ion == 0) { + ipsav = *nolev * 12.f / 7 + 11; + ipsav0 = ipsav; + if (*isig != 0) { + +/* Adjust for signature */ + + *(unsigned char *)notenumq = (char) (*nolev % 7 + 48); + if (*isig >= i_indx("4152630", notenumq, (ftnlen)7, (ftnlen)1) + ) { + ++ipsav; + } else if (-(*isig) >= i_indx("0362514", notenumq, (ftnlen)7, + (ftnlen)1)) { + --ipsav; + } + } + +/* Deal with accidentals. */ + +/* iacc 0 1 2 3 4 5 6 7 */ +/* effect X fl sh na X dfl dsh X */ +/* iashft X -1 1 0 X -2 2 X */ + + jacc = 0; + eximacc = FALSE_; + if (*iacc > 0) { + +/* Adjust key-sig-adjusted pitch for explicit accidental (and exit) */ + + jacc = iashft_(iacc); + eximacc = TRUE_; + if (! commidi_1.relacc) { + jacc = jacc + ipsav0 - ipsav; + } + +/* (Above) Shift applies to diatonic pitch but will be added to adjusted one */ + + } else if (commidi_1.naccim[*icm] > 0) { + +/* Possible implicit accidental from earlier in the bar */ +/* Check for prior accid in this bar at this note level */ + + i__2 = commidi_1.naccim[*icm]; + for (kacc = 1; kacc <= i__2; ++kacc) { + if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) { + jacc = commidi_1.jaccim[*icm + kacc * 25 - 25]; + eximacc = TRUE_; + if (! commidi_1.relacc) { + jacc = jacc + ipsav0 - ipsav; + } + goto L4; + } +/* L3: */ + } +L4: + ; + } + +/* Must split off the following if block from those above because chord */ +/* notes can cause naccim>0, forcing us to miss other chord note's */ +/* accross-bar-line accidental */ + + if (comslm_1.naccbl[*icm] > 0 && ! eximacc) { + +/* Possible carryover accid from prior bar (or prior same-pitch note). */ + + i__2 = comslm_1.naccbl[*icm]; + for (kacc = 1; kacc <= i__2; ++kacc) { + if (comslm_1.laccbl[*icm + kacc * 25 - 25] == *nolev) { + jacc = comslm_1.jaccbl[*icm + kacc * 25 - 25]; + +/* Since we are *using* the bar-line accid, must flag it to be saved for next. */ + + ++comslm_1.nusebl; + comips_1.jusebl[comslm_1.nusebl - 1] = (shortint) + jacc; + comips_1.lusebl[comslm_1.nusebl - 1] = (shortint) (* + nolev); + if (! commidi_1.relacc) { + jacc = jacc + ipsav0 - ipsav; + } + goto L22; + } +/* L21: */ + } +L22: + ; + } + ipsav += jacc; + +/* Midi transpositions */ + + ipsav += commvel_1.midtc[*icm]; + } + if (commidi_1.notmain) { + commidi_1.mcpitch[commidi_1.nmidcrd - 1] = ipsav; + +/* Save pitch for tie checks */ + + if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm]) { + comips_1.ipslon[*icm] = (shortint) ipsav; + } + } else { + ++commidi_1.imidi[*icm]; + if (ion == 0) { + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( + shortint) ipsav; + if (comslm_1.levson[*icm] == *nolev && ! comslm_1.slmon[*icm]) + { + comips_1.ipslon[*icm] = (shortint) ipsav; + } + } else { + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( + shortint) commidi_1.mcpitch[ion - 1]; + } + } + if (ion == 0) { + +/* Only record accids for non-chords, main chord note during chord iteration */ +/* and chordnotes on first call but not during iteration */ + + if (*iacc > 0) { + +/* Set marker for accidental for possible continuations later this bar */ +/* but first check and clear earlier ones on same note. */ + + i__2 = commidi_1.naccim[*icm]; + for (kacc = 1; kacc <= i__2; ++kacc) { + if (commidi_1.laccim[*icm + kacc * 25 - 25] == *nolev) { + i__3 = commidi_1.naccim[*icm] - 1; + for (macc = kacc; macc <= i__3; ++macc) { + commidi_1.laccim[*icm + macc * 25 - 25] = + commidi_1.laccim[*icm + (macc + 1) * 25 - + 25]; + commidi_1.jaccim[*icm + macc * 25 - 25] = + commidi_1.jaccim[*icm + (macc + 1) * 25 - + 25]; +/* L24: */ + } + goto L25; + } +/* L23: */ + } + goto L26; +L25: + --commidi_1.naccim[*icm]; +L26: + +/* Flag new accidental */ + + ++commidi_1.naccim[*icm]; + commidi_1.laccim[*icm + commidi_1.naccim[*icm] * 25 - 25] = * + nolev; + commidi_1.jaccim[*icm + commidi_1.naccim[*icm] * 25 - 25] = + iashft_(iacc); + } + +/* Bail if this is a chord note on the first call (from docrd) */ + + if (commidi_1.notmain) { + chkimidi_(icm); + return 0; + } + } + +/* Vel */ + + ++commidi_1.imidi[*icm]; +/* mmidi(icm,imidi(icm)) = 127 */ + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) + commvel_1.midvelc[*icm]; + chkimidi_(icm); +/* L7: */ + } + +/* For tie checks */ + + if (comslm_1.levson[*icm] > 0 && ! comslm_1.slmon[*icm]) { + comslm_1.imidso[*icm] = commidi_1.imidi[*icm]; + } + +/* Entry point for special rests at section ends (endrest=T) */ + +L20: + +/* Now insert all the ends */ + + i__1 = commidi_1.nmidcrd; + for (ioff = 0; ioff <= i__1; ++ioff) { + if (ioff == 0) { + +/* time to end */ + + r__1 = *time * 15; + idur1 = i_nint(&r__1); + r__1 = commidi_1.trest[*icm] * 15; + if (! (*endrest) || comevent_1.miditime == i_nint(&r__1)) { + idur = idur1 - commidi_1.mgap; + } else { + idur = idur1; + } + +/* Deal with roundoff problems with 7-tuplets on half or quarters */ + + if (idur1 == 69) { + ++comdiag_1.n69[*icm]; +/* if (mod(n69(icm)+6,7) .gt. 3) idur = 58 */ + if ((comdiag_1.n69[*icm] + 6) % 7 > 3) { + idur = idur1 - commidi_1.mgap - 1; + } + } else if (idur1 == 34) { + ++comdiag_1.n34[*icm]; + if ((comdiag_1.n34[*icm] + 6) % 7 > 4) { + idur = idur1 - commidi_1.mgap + 1; + } + } + idurvar = isetvarlen_(&idur, &nby2off); + if (nby2off > 4) { + s_wsle(&io___92); + do_lio(&c__9, &c__1, "You got >4 bytes, something is bogus.", + (ftnlen)37); + e_wsle(); + stop1_(); + } + ++commidi_1.imidi[*icm]; + chkimidi_(icm); + i__2 = nby2off; + for (i__ = 1; i__ <= i__2; ++i__) { + commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nby2off - i__) + * 25 - 25] = (shortint) (idurvar % 256); + if (nby2off > 1) { + idurvar /= 256; + } +/* L1: */ + } + commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nby2off - 1; + } else { + +/* Inserting end of chord note, delta time is 0 */ + + ++commidi_1.imidi[*icm]; + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0; + } + +/* Note off */ + + ++commidi_1.imidi[*icm]; +/* mmidi(icm,imidi(icm)) = 8*16+icm */ + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = (shortint) ( + icmm[*icm] + 128); + +/* Pitch */ + + ++commidi_1.imidi[*icm]; + if (ioff == 0) { + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( + shortint) ipsav; + } else { + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = ( + shortint) commidi_1.mcpitch[ioff - 1]; + } + +/* Vel */ + + ++commidi_1.imidi[*icm]; + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = 0; + chkimidi_(icm); + if (*endrest) { + return 0; + } + +/* print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time */ + +/* L8: */ + } + comslm_1.naccbl[*icm] = comslm_1.nusebl; + if (comslm_1.nusebl > 0) { + +/* Fix tables of "bar-line" accids that are saved due to consecutive notes. */ + + i__1 = comslm_1.nusebl; + for (kacc = 1; kacc <= i__1; ++kacc) { + comslm_1.laccbl[*icm + kacc * 25 - 25] = comips_1.lusebl[kacc - 1] + ; + comslm_1.jaccbl[*icm + kacc * 25 - 25] = comips_1.jusebl[kacc - 1] + ; +/* L30: */ + } + comslm_1.nusebl = 0; + } + +/* Begin tie checks */ + + if (comslm_1.slmon[*icm]) { + +/* Prior note had a slur start */ + + if (comslm_1.levson[*icm] == comslm_1.levsoff[*icm] && *iacc == 0) { + +/* We have a tie! (Assumed there would be no accidental on tie-ending note) */ +/* Make a list of times of all events back to the one starting at imidso+1, */ +/* which is at or before where the tie started. Ident tie start and stop by */ +/* comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) */ +/* Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial */ +/* time. */ + nsav4tie = 0; + imidt = comslm_1.imidso[*icm]; +L10: + ++nsav4tie; + itiesav[nsav4tie * 5 - 5] = igetvarlen_(commidi_1.mmidi, icm, & + imidt, &nbytes); + imidt += nbytes; + for (j = 1; j <= 3; ++j) { + itiesav[j + 1 + nsav4tie * 5 - 6] = commidi_1.mmidi[*icm + ( + imidt + j) * 25 - 25]; +/* L11: */ + } + imidt += 3; + if (nsav4tie == 1) { + itiesav[4] = itiesav[0]; + } else { + itiesav[nsav4tie * 5 - 1] = itiesav[nsav4tie * 5 - 5] + + itiesav[(nsav4tie - 1) * 5 - 1]; + } + if (imidt != commidi_1.imidi[*icm]) { + goto L10; + } + +/* Find which two pitches agree with saved slur pitch. */ + + it1found = FALSE_; + i__1 = nsav4tie; + for (it2 = 1; it2 <= i__1; ++it2) { + if (itiesav[it2 * 5 - 3] == comips_1.ipslon[*icm]) { + if (it1found) { + goto L13; + } + it1 = it2; + it1found = TRUE_; + } +/* L12: */ + } + printl_("Program error, tied notes, send source to Dr. Don", ( + ftnlen)49); + it1 = nsav4tie + 1; + it2 = nsav4tie + 1; +L13: + +/* List the positions we want to keep */ + + jsav = 0; + i__1 = nsav4tie; + for (isav = 1; isav <= i__1; ++isav) { + if (isav == it1 || isav == it2) { + goto L14; + } + ++jsav; + itk[jsav - 1] = (shortint) isav; +L14: + ; + } + nsav4tie += -2; + +/* Now dump events it1 & it2, recompute times, restack mmidi. */ + + commidi_1.imidi[*icm] = comslm_1.imidso[*icm]; + i__1 = nsav4tie; + for (isav = 1; isav <= i__1; ++isav) { + if (isav == 1) { + idurvar = isetvarlen_(&itiesav[itk[isav - 1] * 5 - 1], & + nbytes); + } else { + i__2 = itiesav[itk[isav - 1] * 5 - 1] - itiesav[itk[isav + - 2] * 5 - 1]; + idurvar = isetvarlen_(&i__2, &nbytes); + } + ++commidi_1.imidi[*icm]; + i__2 = nbytes; + for (i__ = 1; i__ <= i__2; ++i__) { + commidi_1.mmidi[*icm + (commidi_1.imidi[*icm] + nbytes - + i__) * 25 - 25] = (shortint) (idurvar % 256); + if (nbytes > 1) { + idurvar /= 256; + } +/* L16: */ + } + commidi_1.imidi[*icm] = commidi_1.imidi[*icm] + nbytes - 1; + for (i__ = 2; i__ <= 4; ++i__) { + ++commidi_1.imidi[*icm]; + commidi_1.mmidi[*icm + commidi_1.imidi[*icm] * 25 - 25] = + (shortint) itiesav[i__ + itk[isav - 1] * 5 - 6]; +/* L17: */ + } +/* L15: */ + } + } + comslm_1.slmon[*icm] = FALSE_; + comslm_1.levsoff[*icm] = 0; + if (! comslm_1.dbltie) { + comslm_1.levson[*icm] = 0; + } + } + if (comslm_1.levson[*icm] > 0) { + comslm_1.slmon[*icm] = TRUE_; + } + if (commidi_1.nmidcrd > 0) { + commidi_1.nmidcrd = 0; + } + chkimidi_(icm); + return 0; +} /* addmidi_ */ + +/* Subroutine */ int addstr_(char *notexq, integer *lnote, char *soutq, + integer *lsout, ftnlen notexq_len, ftnlen soutq_len) +{ + /* System generated locals */ + address a__1[2]; + integer i__1[2]; + char ch__1[81]; + + /* Builtin functions */ + integer s_wsfe(cilist *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer do_fio(integer *, char *, ftnlen), e_wsfe(void); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___104 = { 0, 11, 0, "(a)", 0 }; + + + if (*lsout + *lnote > 72) { + if (comlast_1.islast) { + s_wsfe(&io___104); +/* Writing concatenation */ + i__1[0] = *lsout, a__1[0] = soutq; + i__1[1] = 1, a__1[1] = "%"; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)81); + do_fio(&c__1, ch__1, *lsout + 1); + e_wsfe(); + } + *lsout = 0; + } + if (*lsout > 0) { +/* Writing concatenation */ + i__1[0] = *lsout, a__1[0] = soutq; + i__1[1] = *lnote, a__1[1] = notexq; + s_cat(soutq, a__1, i__1, &c__2, (ftnlen)80); + } else { + s_copy(soutq, notexq, (ftnlen)80, (*lnote)); + } + *lsout += *lnote; + return 0; +} /* addstr_ */ + +/* Subroutine */ int adjusteskz_(integer *ib, real *squez, integer *istart, + integer *istop, real *poenom) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1; + + /* Local variables */ + static integer in, iaskb, inmin; + static real eskadd; + + +/* For block ib, this adds accidental spaces to eskz, for use in getting */ +/* length of xtup bracket and slopes of brackets and beams. */ + + /* Parameter adjustments */ + --istop; + --istart; + --squez; + + /* Function Body */ + inmin = istart[*ib] + 1; + i__1 = comas1_1.naskb; + for (iaskb = 1; iaskb <= i__1; ++iaskb) { + if (comas1_1.task[iaskb - 1] < all_1.to[istart[*ib] - 1] - + comtol_1.tol) { + goto L10; + } + eskadd = comas1_1.wask[iaskb - 1] / *poenom - comas1_1.elask[iaskb - + 1]; + i__2 = comntot_1.ntot; + for (in = inmin; in <= i__2; ++in) { + if (all_1.to[in - 1] > comas1_1.task[iaskb - 1] - comtol_1.tol) { + comeskz2_1.eskz2[all_1.ivxo[in - 1] + all_1.ipo[in - 1] * 24 + - 25] += eskadd; + if ((r__1 = all_1.to[in - 1] - comas1_1.task[iaskb - 1], dabs( + r__1)) < comtol_1.tol) { + --inmin; + } + } else { + ++inmin; + } +/* L11: */ + } +L10: + ; + } + return 0; +} /* adjusteskz_ */ + +/* Subroutine */ int askfig_(char *pathnameq, integer *lpath, char *basenameq, + integer *lbase, logical *figbass, logical *istype0, ftnlen + pathnameq_len, ftnlen basenameq_len) +{ + /* System generated locals */ + address a__1[3], a__2[2]; + integer i__1[3], i__2[2], i__3; + char ch__1[1], ch__2[88], ch__3[15], ch__4[5], ch__5[4]; + olist o__1; + cllist cl__1; + alist al__1; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer f_open(olist *), f_rew(alist *), f_clos(cllist *), s_wsfe(cilist * + ), do_fio(integer *, char *, ftnlen), e_wsfe(void), s_rsfe(cilist + *), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen), s_wsfi( + icilist *), e_wsfi(void), i_indx(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer il; + static char sq[1]; + static integer ihs; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static logical done; + extern integer llen_(char *, integer *, ftnlen); + static char outq[129]; + extern /* Subroutine */ int moveln_(integer *, integer *, logical *); + static integer lenout; + extern /* Subroutine */ int putast_(real *, integer *, char *, ftnlen); + static integer indxask; + + /* Fortran I/O blocks */ + static cilist io___112 = { 0, 12, 0, "(a)", 0 }; + static cilist io___113 = { 0, 12, 0, "(a)", 0 }; + static cilist io___115 = { 0, 11, 1, "(a129)", 0 }; + static icilist io___117 = { 0, outq+11, 0, "(f4.1)", 4, 1 }; + static cilist io___120 = { 0, 12, 0, "(a)", 0 }; + static cilist io___121 = { 0, 16, 1, "(a129)", 0 }; + static cilist io___122 = { 0, 12, 0, "(a)", 0 }; + + + chax_(ch__1, (ftnlen)1, &c__92); + *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; + o__1.oerr = 0; + o__1.ounit = 12; + o__1.ofnmlen = *lpath + *lbase + 4; +/* Writing concatenation */ + i__1[0] = *lpath, a__1[0] = pathnameq; + i__1[1] = *lbase, a__1[1] = basenameq; + i__1[2] = 4, a__1[2] = ".tex"; + s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)88); + o__1.ofnm = ch__2; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + +/* Transfer first 5 lines of main internal TeX file */ + + for (il = 1; il <= 5; ++il) { + moveln_(&c__11, &c__12, &done); +/* L11: */ + } + if (*istype0) { + +/* Transfer literal TeX stuff from special scratch file */ + + al__1.aerr = 0; + al__1.aunit = 17; + f_rew(&al__1); +L10: + moveln_(&c__17, &c__12, &done); + if (! done) { + goto L10; + } + cl__1.cerr = 0; + cl__1.cunit = 17; + cl__1.csta = 0; + f_clos(&cl__1); + } + +/* Transfer next 2 lines from main scratch file */ + + for (il = 1; il <= 2; ++il) { + moveln_(&c__11, &c__12, &done); +/* L3: */ + } + if (compoi_1.ispoi) { + s_wsfe(&io___112); +/* Writing concatenation */ + i__2[0] = 1, a__2[0] = sq; + i__2[1] = 14, a__2[1] = "input musixpoi"; + s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15); + do_fio(&c__1, ch__3, (ftnlen)15); + e_wsfe(); + } + if (combbm_1.isbbm) { + s_wsfe(&io___113); +/* Writing concatenation */ + i__2[0] = 1, a__2[0] = sq; + i__2[1] = 14, a__2[1] = "input musixbbm"; + s_cat(ch__3, a__2, i__2, &c__2, (ftnlen)15); + do_fio(&c__1, ch__3, (ftnlen)15); + e_wsfe(); + } + if (*figbass) { + +/* Transfer .fig data from scratch (unit 14) into external .tex (unit 12) */ + +L4: + moveln_(&c__14, &c__12, &done); + if (! done) { + goto L4; + } + cl__1.cerr = 0; + cl__1.cunit = 14; + cl__1.csta = 0; + f_clos(&cl__1); + } + comas3_1.iask = 0; + ihs = 0; +L1: + i__3 = s_rsfe(&io___115); + if (i__3 != 0) { + goto L999; + } + i__3 = do_fio(&c__1, outq, (ftnlen)129); + if (i__3 != 0) { + goto L999; + } + i__3 = e_rsfe(); + if (i__3 != 0) { + goto L999; + } + +/* Hardspaces. */ + +/* Writing concatenation */ + i__2[0] = 1, a__2[0] = sq; + i__2[1] = 4, a__2[1] = "xard"; + s_cat(ch__4, a__2, i__2, &c__2, (ftnlen)5); + if (s_cmp(outq, ch__4, (ftnlen)5, (ftnlen)5) == 0) { + ++ihs; + *(unsigned char *)&outq[1] = 'h'; + s_wsfi(&io___117); + do_fio(&c__1, (char *)&comhsp_1.hpttot[ihs - 1], (ftnlen)sizeof(real)) + ; + e_wsfi(); + lenout = 19; + goto L9; + } + +/* This part hard-wires ask's into new .tex file as ast's */ + +L2: +/* Writing concatenation */ + i__2[0] = 1, a__2[0] = sq; + i__2[1] = 3, a__2[1] = "ask"; + s_cat(ch__5, a__2, i__2, &c__2, (ftnlen)4); + indxask = i_indx(outq, ch__5, (ftnlen)129, (ftnlen)4); + if (indxask != 0) { + ++comas3_1.iask; + putast_(&comas3_1.ask[comas3_1.iask - 1], &indxask, outq, (ftnlen)129) + ; + goto L2; + } + lenout = llen_(outq, &c__129, (ftnlen)129); +L9: + s_wsfe(&io___120); + do_fio(&c__1, outq, lenout); + e_wsfe(); + +/* If this is the line with "readmod", check for topmods. */ + + if (comas3_1.topmods && s_cmp(outq + 1, "readmod", (ftnlen)7, (ftnlen)7) + == 0) { + comas3_1.topmods = FALSE_; + al__1.aerr = 0; + al__1.aunit = 16; + f_rew(&al__1); + for (il = 1; il <= 1000; ++il) { + i__3 = s_rsfe(&io___121); + if (i__3 != 0) { + goto L8; + } + i__3 = do_fio(&c__1, outq, (ftnlen)129); + if (i__3 != 0) { + goto L8; + } + i__3 = e_rsfe(); + if (i__3 != 0) { + goto L8; + } + lenout = llen_(outq, &c__129, (ftnlen)129); + +/* We inserted the '%' in subroutine littex, to guarantee including blank. */ + + s_wsfe(&io___122); + do_fio(&c__1, outq, lenout); + e_wsfe(); +/* L7: */ + } +L8: + cl__1.cerr = 0; + cl__1.cunit = 16; + cl__1.csta = 0; + f_clos(&cl__1); + } + goto L1; +L999: + cl__1.cerr = 0; + cl__1.cunit = 11; + cl__1.csta = 0; + f_clos(&cl__1); + cl__1.cerr = 0; + cl__1.cunit = 12; + cl__1.csta = 0; + f_clos(&cl__1); + return 0; +} /* askfig_ */ + +/* Subroutine */ int backfill_(integer *iunit, char *oldq, integer *lenold, + char *newq, integer *lennew, ftnlen oldq_len, ftnlen newq_len) +{ + /* System generated locals */ + address a__1[3]; + integer i__1, i__2[3]; + alist al__1; + + /* Builtin functions */ + integer f_back(alist *), s_rsfe(cilist *), do_fio(integer *, char *, + ftnlen), e_rsfe(void), i_indx(char *, char *, ftnlen, ftnlen); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, + char **, integer *, integer *, ftnlen); + integer s_wsfe(cilist *), e_wsfe(void); + + /* Local variables */ + static integer linesback, ndx, line; + static char nowq[128], lineq[128*200]; + + /* Fortran I/O blocks */ + static cilist io___124 = { 0, 0, 0, "(a)", 0 }; + static cilist io___129 = { 0, 0, 0, "(a128)", 0 }; + + + +/* In iunit, looks backward for oldq, overwrites newq */ +/* Safest if both are same length! */ + + linesback = 0; +L1: + al__1.aerr = 0; + al__1.aunit = *iunit; + f_back(&al__1); + io___124.ciunit = *iunit; + s_rsfe(&io___124); + do_fio(&c__1, nowq, (ftnlen)128); + e_rsfe(); + ndx = i_indx(nowq, oldq, (ftnlen)128, (*lenold)); + +/* Save the line just read */ + + ++linesback; + s_copy(lineq + (linesback - 1 << 7), nowq, (ftnlen)128, (ftnlen)128); + if (ndx == 0) { + al__1.aerr = 0; + al__1.aunit = *iunit; + f_back(&al__1); + goto L1; + } + +/* If here, it's replacement time. */ + + i__1 = ndx + *lenold - 1; +/* Writing concatenation */ + i__2[0] = ndx - 1, a__1[0] = nowq; + i__2[1] = *lennew, a__1[1] = newq; + i__2[2] = 128 - i__1, a__1[2] = nowq + i__1; + s_cat(lineq + (linesback - 1 << 7), a__1, i__2, &c__3, (ftnlen)128); + al__1.aerr = 0; + al__1.aunit = *iunit; + f_back(&al__1); + for (line = linesback; line >= 1; --line) { + io___129.ciunit = *iunit; + s_wsfe(&io___129); + do_fio(&c__1, lineq + (line - 1 << 7), (ftnlen)128); + e_wsfe(); +/* L2: */ + } + return 0; +} /* backfill_ */ + +/* Subroutine */ int beamend_(char *notexq, integer *lnote, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[4], a__2[3], a__3[2]; + integer i__1, i__2[4], i__3[3], i__4[2]; + char ch__1[1]; + + /* Builtin functions */ + integer pow_ii(integer *, integer *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + static integer ip, mp, len, imp; + extern integer log2_(integer *); + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer nole; + static char ulqq[1]; + extern /* Subroutine */ int stop1_(void); + extern integer ncmid_(integer *, integer *); + static integer ndsav; + static char tempq[4], noteq[8]; + extern /* Subroutine */ int notex_(char *, integer *, ftnlen), ntrbbb_( + integer *, char *, char *, integer *, char *, integer *, ftnlen, + ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *, + ftnlen); + static logical isdotm; + static integer lnoten, multip; + extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) + ; + + /* Fortran I/O blocks */ + static cilist io___136 = { 0, 6, 0, 0, 0 }; + static cilist io___137 = { 0, 6, 0, 0, 0 }; + + + ip = all_1.ipo[all_1.jn - 1]; + multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8; + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 4) { + +/* This is the LAST note in the xtup (i.e., all rests before). Make single. */ + + i__1 = 4 - multip; + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); + notex_(notexq, lnote, (ftnlen)79); + strtmid_1.ixrest[commvl_1.ivx - 1] = 0; + return 0; + } + nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; + +/* Check for special situations with 2nds (see precrd) */ + + if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) { + --nole; + } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) { + ++nole; + } + if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { + +/* Xtuplet with no beam, just put in the right kind of note */ + + if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) { + +/* Forced stem direction */ + + ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; + i__1 = 4 - multip; + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); + if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) { + all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2; + } + notex_(notexq, lnote, (ftnlen)79); + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav; + } else { + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + *lnote = lnoten + 3; + if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) + { + +/* Prior note is not regular-dotted */ + + if (multip == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "q"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } else if (multip == -1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "h"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } else if (multip == 1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "c"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } else if (multip == 2) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 2, a__1[1] = "cc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + ++(*lnote); + } else if (multip == 3) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 3, a__1[1] = "ccc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + *lnote += 2; + } else if (multip == -2) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 2, a__2[1] = "wh"; + i__3[2] = 8, a__2[2] = noteq; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + } else if (multip == -3) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 5, a__2[1] = "breve"; + i__3[2] = 8, a__2[2] = noteq; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + *lnote += 3; + } else { + s_wsle(&io___136); + e_wsle(); + s_wsle(&io___137); + do_lio(&c__9, &c__1, "(Error in beamend, send source to " + "Dr. Don)", (ftnlen)42); + e_wsle(); + stop1_(); + } + } else { + +/* Prior note is regular-dotted so this one is halved */ + + if (multip == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "c"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } else if (multip == -1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "q"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } else if (multip == -2) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "h"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + i__2[3] = 8, a__1[3] = noteq; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + } + } + } + return 0; + } + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + *lnote = 0; + +/* New way, with flipend, which was computed in beamstrt. */ + + if (strtmid_1.flipend[commvl_1.ivx - 1] && bit_test(all_1.ipl[ + commvl_1.ivx + ip * 24 - 25],30)) { + i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25]; + chax_(ch__1, (ftnlen)1, &i__1); + *(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx + - 1] * 24 - 25] = *(unsigned char *)&ch__1[0]; + } + if (ip > all_1.ibm1[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - + 25]) { + +/* This is not a one-noter from beam-jump. Check if multiplicity has increased */ + + if (bit_test(all_1.irest[commvl_1.ivx + (ip - 1) * 24 - 25],0)) { + +/* Prior note is a rest, check one before that */ + + mp = (all_1.mult[commvl_1.ivx + (ip - 2) * 24 - 25] & 15) - 8; + } else { + mp = (all_1.mult[commvl_1.ivx + (ip - 1) * 24 - 25] & 15) - 8; + } + if (multip > mp) { + +/* Assume 1-3, 2-3, or 1-2 */ + + i__1 = mp + 1; + for (imp = multip; imp >= i__1; --imp) { + ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, + lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); +/* L2: */ + } + } else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) + { + +/* 2nd member of dotted xtup */ + + i__1 = multip + 1; + ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, + lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); + } + } + +/* Beam termination and direction analysis */ + + if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23) && ! + combjmp_1.isbjmp) { + +/* This is the end of the first segment in a jump-beam. ivbj1=ivx will be number */ +/* of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the */ +/* voice of the 2nd part of jumped beam. (May need special treatment for */ +/* multi-segment jump-beams */ + + combjmp_1.isbjmp = TRUE_; + combjmp_1.ivbj1 = commvl_1.ivx; + combjmp_1.ivbj2 = 0; + } + if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) { + +/* This is either a normal beamend or end of a sequence of jump-beam segments, */ +/* so some sort of termination is required */ + + *(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; + if (! combjmp_1.isbjmp || commvl_1.ivx != combjmp_1.ivbj2) { + +/* Normal termination */ + + i__1 = commvl_1.ivx % 24; + ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); + } else { + +/* Terminate a sequence of jump-beam segments. */ + + i__1 = 225 - *(unsigned char *)ulqq; + chax_(ch__1, (ftnlen)1, &i__1); + *(unsigned char *)ulqq = *(unsigned char *)&ch__1[0]; + i__1 = combjmp_1.ivbj1 % 24; + ntrbbb_(&c__1, "t", ulqq, &i__1, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); + } + } + +/* And now the note */ + + if (*lnote > 0) { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = all_1.sq; + i__3[2] = 2, a__2[2] = "qb"; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + } else { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = all_1.sq; + i__4[1] = 2, a__3[1] = "qb"; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + } + *lnote += 3; + isdotm = FALSE_; + if (! comxtup_1.vxtup[commvl_1.ivx - 1]) { + i__1 = log2_(&all_1.nodur[commvl_1.ivx + ip * 24 - 25]); + if (pow_ii(&c__2, &i__1) != all_1.nodur[commvl_1.ivx + ip * 24 - 25]) + { + if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) { +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = 1, a__3[1] = "p"; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = 1, a__3[1] = "m"; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + isdotm = TRUE_; + } + ++(*lnote); + } + } + +/* 5/25/08 Allow >12 */ +/* 5/9/10 Up to 24; replace 24 with 0 */ + + if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) { +/* call istring(mod(ivx,12),tempq,len) */ + i__1 = commvl_1.ivx % 24; + istring_(&i__1, tempq, &len, (ftnlen)4); + } else { +/* call istring(mod(ivbj1,12),tempq,len) */ + i__1 = combjmp_1.ivbj1 % 24; + istring_(&i__1, tempq, &len, (ftnlen)4); + } + if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2 && ! bit_test( + all_1.irest[commvl_1.ivx + ip * 24 - 25],23)) { + combjmp_1.isbjmp = FALSE_; + } +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = len, a__3[1] = tempq; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + *lnote += len; +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = lnoten, a__3[1] = noteq; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + *lnote += lnoten; + if (isdotm) { + if (lnoten == 1) { +/* Writing concatenation */ + i__2[0] = *lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "{"; + i__2[2] = 1, a__1[2] = noteq; + i__2[3] = 1, a__1[3] = "}"; + s_cat(notexq, a__1, i__2, &c__4, (ftnlen)79); + *lnote += 3; + } else { + i__1 = lnoten - 2; +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = lnoten - 1 - i__1, a__3[1] = noteq + i__1; + s_cat(notexq, a__3, i__4, &c__2, (ftnlen)79); + ++(*lnote); + } + } + return 0; +} /* beamend_ */ + +/* Subroutine */ int beamid_(char *notexq, integer *lnote, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[3], a__2[2], a__3[4]; + integer i__1, i__2[3], i__3[2], i__4, i__5, i__6[4]; + real r__1; + char ch__1[1]; + + /* Builtin functions */ + integer pow_ii(integer *, integer *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + extern integer igetbits_(integer *, integer *, integer *); + extern logical isdotted_(integer *, integer *, integer *); + static integer im, ip, len, ivb, iud, mua, mub, iup; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer nole; + static char ulqq[1]; + extern integer ncmid_(integer *, integer *); + static integer ipmid, iflop, ndsav; + static char noteq[8], tempq[4]; + extern /* Subroutine */ int notex_(char *, integer *, ftnlen); + extern integer levrn_(integer *, integer *, integer *, integer *, integer + *); + static integer nlnum, multl, multr; + extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, + char *, integer *, ftnlen, ftnlen, ftnlen); + static integer ipleft; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static real xnlmid; + static logical isdotm; + static integer lnoten, mprint, multip; + extern /* Subroutine */ int putxtn_(integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, real *, + integer *, integer *, char *, integer *, integer *, real *, + integer *, integer *, logical *, ftnlen); + static integer ipright; + extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) + ; + + *lnote = 0; + ip = all_1.ipo[all_1.jn - 1]; + nole = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; + +/* Check for special situations with 2nds (see precrd) */ + + if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],30)) { + --nole; + } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],31)) { + ++nole; + } + if (! bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { + multip = (all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8; +/* if (btest(islur(ivx,ip-1),3)) multip = multip+1 */ + +/* (Above test OK since must have ip>1). Double dotted note preceding */ + +/* Move the following, because can't ask for note until after checking for */ +/* embedded xtup with number, due to ordering/octave feature. */ + +/* call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) */ + } + if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],28)) { + comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_; + } + if (comxtup_1.vxtup[commvl_1.ivx - 1]) { + +/* In an xtup */ + + if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { + +/* Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK */ + + i__1 = 4 - ((all_1.mult[commvl_1.ivx + ip * 24 - 25] & 15) - 8); + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, &i__1); + notex_(notexq, lnote, (ftnlen)79); + +/* Re-zero so next note does not get confused */ + + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = 0; + return 0; + } +/* if (multip.le.0) then */ +/* if (multip.le.0 .or. */ +/* * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then */ + if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { + +/* Xtuplet with no beam, just put in the right kind of note */ + + if (bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],30)) { + +/* Forced stem direction */ + + ndsav = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; + i__1 = 4 - multip; + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = pow_ii(&c__2, & + i__1); + if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) || + bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) + { + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = all_1.nodur[ + commvl_1.ivx + ip * 24 - 25] * 3 / 2; + } else if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - + 25],27)) { + all_1.nodur[commvl_1.ivx + ip * 24 - 25] /= 2; + } + notex_(notexq, lnote, (ftnlen)79); + all_1.nodur[commvl_1.ivx + ip * 24 - 25] = ndsav; + } else { + +/* Use ulq for stem direction */ + + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + *lnote = 3; + if (! bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25], + 27)) { + +/* Prior note is not regular-dotted */ + + if (multip == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "q"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == -1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "h"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == 1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "c"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == 2) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 2, a__1[1] = "cc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + *lnote = 4; + } else if (multip == 3) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 3, a__1[1] = "ccc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + *lnote = 5; + } else if (multip == -2) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 2, a__2[1] = "wh"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } + if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) + { + +/* This note is regular dotted non-beamed xtup */ + +/* Writing concatenation */ + i__3[0] = 3, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote = 4; + } + } else { + +/* Prior note is regular-dotted so this one is halved */ + + if (multip == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "c"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == -1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "q"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == -2) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "h"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } + } +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 8, a__2[1] = noteq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += lnoten; + } + return 0; + } else if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) { + +/* In the beamed xtup but not the last note */ + + if (all_1.nodur[commvl_1.ivx + (ip - 1) * 24 - 25] > 0) { + +/* Embedded Xtup, mult>0, starts here. Put in number if needed */ + + ++comxtup_1.nxtinbm[commvl_1.ivx - 1]; + iud = 1; + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25] == 'u') { + iud = -1; + } + +/* Get ip#, notelevel of middle note (or gap) in xtup */ + + ipmid = ip + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25] / 2; + i__1 = ncmid_(&all_1.iv, &ipmid); + i__4 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8; + xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24 + - 25], &all_1.irest[commvl_1.ivx + ipmid * 24 - 25], & + iud, &i__1, &i__4); + if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25] % 2 == 0) { + i__4 = ipmid - 1; + i__1 = ncmid_(&all_1.iv, &i__4); + i__5 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 - + 25]) - 8; + xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + ( + ipmid - 1) * 24 - 25], &all_1.irest[commvl_1.ivx + + (ipmid - 1) * 24 - 25], &iud, &i__1, &i__5)) / + 2; + } + iflop = 0; + if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ip), dabs(r__1)) < + 3.f) { + iflop = -iud; + } + iup = iud + (iflop << 1); + if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],14)) { + iup = -iup; + iflop = 0; + if (iud * iup < 0) { + iflop = iup; + } + } + +/* Place number if needed */ + + if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],31)) { + mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - + 25], &c__5, &c__22); + if (mprint == 0) { + mprint = comxtup_1.mtupv[commvl_1.ivx + + comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25] + ; + } + i__1 = ncmid_(&all_1.iv, &ip); + putxtn_(&mprint, &iflop, &multip, &iud, &comask_1.wheadpt, + &comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx + - 1], &comxtup_1.islope[commvl_1.ivx - 1], & + all_1.slfac, &xnlmid, &all_1.islur[commvl_1.ivx + + ip * 24 - 25], lnote, notexq, &i__1, &nlnum, & + comxtup_1.eloff[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25], &iup, &all_1.irest[ + commvl_1.ivx + ip * 24 - 25], &c_false, (ftnlen) + 79); + } + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + } else { + +/* Intermediate note of xtup */ + + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + } + } else { + +/* Last note of xtup (but not last note of beam!) */ + + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + } + } else if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],0)) { + notex_(notexq, lnote, (ftnlen)79); + return 0; + } else { + i__1 = ncmid_(&all_1.iv, &ip); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + } + +/* Check if multiplicity changes in a way requiring action */ + + ipleft = ip - 1; + if (bit_test(all_1.irest[commvl_1.ivx + ipleft * 24 - 25],0)) { + --ipleft; + } + if (! bit_test(all_1.islur[commvl_1.ivx + ipleft * 24 - 25],20)) { + multl = (15 & all_1.mult[commvl_1.ivx + ipleft * 24 - 25]) - 8; + } else { + multl = 1; + } + mub = multip - multl; + ipright = ip + 1; + if (bit_test(all_1.irest[commvl_1.ivx + ipright * 24 - 25],0)) { + ++ipright; + } + if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],20)) { + multr = (15 & all_1.mult[commvl_1.ivx + ipright * 24 - 25]) - 8; + } else { + multr = 1; + } + mua = multr - multip; + if (mub > 0 || mua < 0) { + +/* Multiplicity has increased from left or will decrease to right. Need action. */ + + if (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2) { + ivb = combjmp_1.ivbj1; + i__1 = 225 - *(unsigned char *)&all_1.ulq[commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; + chax_(ch__1, (ftnlen)1, &i__1); + *(unsigned char *)ulqq = *(unsigned char *)&ch__1[0]; + } else { + ivb = commvl_1.ivx; + *(unsigned char *)ulqq = *(unsigned char *)&all_1.ulq[ + commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25]; + } + if (mua >= 0) { + ntrbbb_(&multip, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); + } else if (multl >= multr) { + i__1 = multr + 1; + for (im = multip; im >= i__1; --im) { + ntrbbb_(&im, "t", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); +/* L1: */ + } + } else { + i__1 = multip; + for (im = multr + 1; im <= i__1; ++im) { + ntrbbb_(&im, "r", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); +/* L2: */ + } + ntrbbb_(&multr, "n", ulqq, &ivb, notexq, lnote, (ftnlen)1, ( + ftnlen)1, (ftnlen)79); + } + } else if (ip > 1) { + +/* Check for 2nd member of dotted xtup */ + + if (bit_test(all_1.nacc[commvl_1.ivx + (ip - 1) * 24 - 25],27)) { + i__1 = multip + 1; + ntrbbb_(&i__1, "t", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, + lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); + } + } + +/* Now put in the note */ + + if (*lnote > 0) { +/* Writing concatenation */ + i__2[0] = *lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = all_1.sq; + i__2[2] = 2, a__1[2] = "qb"; + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 2, a__2[1] = "qb"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } + *lnote += 3; + isdotm = FALSE_; + if (isdotted_(all_1.nodur, &commvl_1.ivx, &ip)) { + +/* rule out ')' */ + + if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],13)) { + if (! bit_test(all_1.islur[commvl_1.ivx + ip * 24 - 25],3)) { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } else { + +/* Double dot */ + +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 2, a__2[1] = "pp"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + } else { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "m"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + isdotm = TRUE_; + } + ++(*lnote); + } else if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],19) || + bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],27)) { + +/* Special dotted notation for 2:1 xtup, or normal dot in xtup */ + +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + +/* 5/25/08 Allow >12 */ + + if (! (combjmp_1.isbjmp && commvl_1.ivx == combjmp_1.ivbj2)) { +/* call istring(mod(ivx,12),tempq,len) */ + i__1 = commvl_1.ivx % 24; + istring_(&i__1, tempq, &len, (ftnlen)4); + } else { +/* call istring(mod(ivbj1,12),tempq,len) */ + i__1 = combjmp_1.ivbj1 % 24; + istring_(&i__1, tempq, &len, (ftnlen)4); + } +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = len, a__2[1] = tempq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += len; +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = lnoten, a__2[1] = noteq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += lnoten; + if (isdotm) { + if (lnoten == 2) { +/* Writing concatenation */ + i__6[0] = *lnote, a__3[0] = notexq; + i__6[1] = 1, a__3[1] = "{"; + i__6[2] = 1, a__3[2] = noteq + 1; + i__6[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__6, &c__4, (ftnlen)79); + *lnote += 3; + } else { + i__1 = lnoten - 2; +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + } + return 0; +} /* beamid_ */ + +/* Subroutine */ int beamn1_(char *notexq, integer *lnote, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[3], a__2[2], a__3[4]; + integer i__1, i__2[3], i__3[2], i__4[4]; + + /* Builtin functions */ + integer pow_ii(integer *, integer *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + static integer nd, im, ip1, len; + extern integer log2_(integer *); + static integer nole; + extern /* Subroutine */ int stop1_(void); + extern integer ncmid_(integer *, integer *); + static integer ndsav; + static char noteq[8]; + extern /* Subroutine */ int notex_(char *, integer *, ftnlen); + static integer multr; + extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, + char *, integer *, ftnlen, ftnlen, ftnlen), notefq_(char *, + integer *, integer *, integer *, ftnlen); + static logical isdotm; + static integer lnoten, multip; + extern /* Subroutine */ int istring_(integer *, char *, integer *, ftnlen) + ; + + /* Fortran I/O blocks */ + static cilist io___175 = { 0, 6, 0, 0, 0 }; + static cilist io___176 = { 0, 6, 0, 0, 0 }; + + + ip1 = all_1.ipo[all_1.jn - 1]; + multip = (15 & all_1.mult[commvl_1.ivx + ip1 * 24 - 25]) - 8; +/* if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then */ + if (! comdraw_1.drawbm[commvl_1.ivx - 1] && bit_test(all_1.irest[ + commvl_1.ivx + ip1 * 24 - 25],0)) { + *lnote = 0; + +/* The rest was already written in beamstrt, so just get out of here */ + + return 0; + } + nole = all_1.nolev[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25]; + +/* Check for special situations with 2nds (see precrd) */ + + if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25], + 30)) { + --nole; + } else if (bit_test(all_1.nacc[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * + 24 - 25],31)) { + ++nole; + } + if (comxtup_1.vxtup[commvl_1.ivx - 1] && ! comdraw_1.drawbm[commvl_1.ivx + - 1]) { + +/* Xtuplet with no beam, just put in the right kind of note */ + + if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],30)) { + +/* Forced stem direction */ + + ndsav = all_1.nodur[commvl_1.ivx + ip1 * 24 - 25]; + i__1 = 4 - multip; + all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = pow_ii(&c__2, &i__1); + if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || + bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { + all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = all_1.nodur[ + commvl_1.ivx + ip1 * 24 - 25] * 3 / 2; + } + notex_(notexq, lnote, (ftnlen)79); + all_1.nodur[commvl_1.ivx + ip1 * 24 - 25] = ndsav; + } else { + i__1 = ncmid_(&all_1.iv, &ip1); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + *lnote = 3; + if (multip == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "q"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == -1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "h"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == 1) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 1, a__1[1] = "c"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else if (multip == 2) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 2, a__1[1] = "cc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + *lnote = 4; + } else if (multip == 3) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = all_1.sq; + i__2[1] = 3, a__1[1] = "ccc"; + i__2[2] = 1, a__1[2] = all_1.ulq + (commvl_1.ivx + + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25); + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + *lnote = 5; + } else if (multip == -2) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 2, a__2[1] = "wh"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } else if (multip == -3) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 5, a__2[1] = "breve"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote = 6; + } else { + s_wsle(&io___175); + e_wsle(); + s_wsle(&io___176); + do_lio(&c__9, &c__1, "(Error in beamn1, send source to Dr. D" + "on)", (ftnlen)41); + e_wsle(); + stop1_(); + } + if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || + bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { +/* Writing concatenation */ + i__3[0] = 3, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote = 4; + } +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 8, a__2[1] = noteq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += lnoten; + } + return 0; + } + +/* Check if mult. decreases from 1st note to 2nd */ + + if (all_1.ibm2[commvl_1.ivx + all_1.ibmcnt[commvl_1.ivx - 1] * 24 - 25] > + ip1 || bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) { + +/* More than one note or single-note before a multiplicity-down-up "][" */ + + if (bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25],20)) { + multr = 1; + } else if (! bit_test(all_1.irest[commvl_1.ivx + (ip1 + 1) * 24 - 25], + 0)) { + multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 1) * 24 - 25]) - 8; + } else { + multr = (15 & all_1.mult[commvl_1.ivx + (ip1 + 2) * 24 - 25]) - 8; + } + *lnote = 0; + if (multr < multip) { + i__1 = multr + 1; + for (im = multip; im >= i__1; --im) { + ntrbbb_(&im, "r", all_1.ulq + (commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25), &commvl_1.ivx, notexq, + lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); +/* L1: */ + } + } + } + +/* Put in the note */ + + if (*lnote > 0) { +/* Writing concatenation */ + i__2[0] = *lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = all_1.sq; + i__2[2] = 2, a__1[2] = "qb"; + s_cat(notexq, a__1, i__2, &c__3, (ftnlen)79); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = all_1.sq; + i__3[1] = 2, a__2[1] = "qb"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } + *lnote += 3; + +/* Check for dot */ + + isdotm = FALSE_; + if (! comxtup_1.vxtup[commvl_1.ivx - 1]) { + nd = all_1.nodur[commvl_1.ivx + all_1.ipo[all_1.jn - 1] * 24 - 25]; + if (nd != 0) { + i__1 = log2_(&nd); + if (pow_ii(&c__2, &i__1) != nd) { + if (! bit_test(all_1.iornq[commvl_1.ivx + ip1 * 24 - 1],13)) { + if (! bit_test(all_1.islur[commvl_1.ivx + ip1 * 24 - 25], + 3)) { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + } else { + +/* Double dot */ + +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 2, a__2[1] = "pp"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + } else { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "m"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + isdotm = TRUE_; + } + ++(*lnote); + } + } + } else if (bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],19) || + bit_test(all_1.nacc[commvl_1.ivx + ip1 * 24 - 25],27)) { + +/* In an xtup with special 2:1 notation with a dot on 1st note, or normal dot */ + +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = 1, a__2[1] = "p"; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + +/* Do the number; 0 if 12 */ + +/* 5/25/08 allow >12 */ + + if (! bit_test(all_1.irest[commvl_1.ivx + ip1 * 24 - 25],24)) { +/* call istring(mod(ivx,12),noteq,len) */ + i__1 = commvl_1.ivx % 24; + istring_(&i__1, noteq, &len, (ftnlen)8); + } else { +/* call istring(mod(ivbj1,12),noteq,len) */ + i__1 = combjmp_1.ivbj1 % 24; + istring_(&i__1, noteq, &len, (ftnlen)8); + } +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = len, a__2[1] = noteq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += len; + i__1 = ncmid_(&all_1.iv, &ip1); + notefq_(noteq, &lnoten, &nole, &i__1, (ftnlen)8); +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = lnoten, a__2[1] = noteq; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + *lnote += lnoten; + if (isdotm) { + if (lnoten == 1) { +/* Writing concatenation */ + i__4[0] = *lnote, a__3[0] = notexq; + i__4[1] = 1, a__3[1] = "{"; + i__4[2] = 1, a__3[2] = noteq; + i__4[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); + *lnote += 3; + } else { + i__1 = lnoten - 2; +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = lnoten - 1 - i__1, a__2[1] = noteq + i__1; + s_cat(notexq, a__2, i__3, &c__2, (ftnlen)79); + ++(*lnote); + } + } + return 0; +} /* beamn1_ */ + +/* Subroutine */ int beamstrt_(char *notexq, integer *lnote, integer *nornb, + integer *ihornb, real *space, real *squez, integer *ib, ftnlen + notexq_len) +{ + /* System generated locals */ + address a__1[3], a__2[2]; + integer i__1, i__2, i__3, i__4[3], i__5[2]; + real r__1; + icilist ici__1; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer i_nint(real *), s_wsfi(icilist *), do_fio(integer *, char *, + ftnlen), e_wsfi(void), pow_ii(integer *, integer *); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer i_sign(integer *, integer *), lbit_shift(integer, integer); + + /* Local variables */ + static logical addbrack; + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + extern integer igetbits_(integer *, integer *, integer *); + static logical usexnumt; + static integer nomornlev, ip, levbracket, ibc, inb, iud, imp, ivf, ipp, + iup; + static logical xto; + static integer ipb1, iadj, icrd; + extern doublereal feon_(real *); + static integer levc, iorn; + static real ymin, ybot; + static integer levx; + static real xnsk; + extern integer ncmid_(integer *, integer *); + static real ybeam; + static integer ipmid, iflop; + static real bmlev; + static integer icrdx, multb, ltemp; + static char noteq[8], tempq[79]; + extern integer levrn_(integer *, integer *, integer *, integer *, integer + *); + static integer nlnum; + extern /* Subroutine */ int notex_(char *, integer *, ftnlen); + static integer isssb; + static real zmult; + extern /* Subroutine */ int ntrbbb_(integer *, char *, char *, integer *, + char *, integer *, ftnlen, ftnlen, ftnlen); + static real xnlmid; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static integer lnoten; + extern /* Subroutine */ int setupb_(real *, integer *, real *, real *, + integer *, real *, integer *); + static integer mprint; + static real xslope; + extern /* Subroutine */ int putxtn_(integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, real *, + integer *, integer *, char *, integer *, integer *, real *, + integer *, integer *, logical *, ftnlen); + static integer maxdrop; + + +/* The following is just to save the outputs from SetupB for the case of */ +/* xtups starting with a rest, where beamstrt is called twice. */ + + /* Parameter adjustments */ + --squez; + --space; + ihornb -= 25; + --nornb; + + /* Function Body */ + ibc = all_1.ibmcnt[commvl_1.ivx - 1]; + ipb1 = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; + multb = (15 & all_1.mult[commvl_1.ivx + ipb1 * 24 - 25]) - 8; + ip = all_1.ipo[all_1.jn - 1]; + +/* Compute slopes and note offsets from start of beam. Inside SetupB, for each */ +/* xtup in the beam, set eloff,mtupv (in comxtup) for printed number. */ + + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 0 && ! bit_test(all_1.nacc[ + commvl_1.ivx + ip * 24 - 25],21)) { + setupb_(comxtup_1.xelsk, &comipb_1.nnb, &comipb_1.sumx, & + comipb_1.sumy, comipb_1.ipb, &comipb_1.smed, & + strtmid_1.ixrest[commvl_1.ivx - 1]); + } + if (bit_test(all_1.nacc[commvl_1.ivx + ip * 24 - 25],21)) { + +/* This is start of later segment of single-slope beam group so use slope and */ +/* height from prior beam. Slope is already OK. */ + + ++comxtup_1.issb[commvl_1.ivx - 1]; + comxtup_1.nolev1[commvl_1.ivx - 1] = comxtup_1.lev1ssb[commvl_1.ivx + + comxtup_1.issb[commvl_1.ivx - 1] * 24 - 25]; + } + *lnote = 0; + comdraw_1.drawbm[commvl_1.ivx - 1] = TRUE_; + if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],28) && + strtmid_1.ixrest[commvl_1.ivx - 1] != 2) { + comxtup_1.vxtup[commvl_1.ivx - 1] = TRUE_; + ++comxtup_1.nxtinbm[commvl_1.ivx - 1]; + +/* irest(28)=>Xtup starts on this note. Set up for xtuplet. */ +/* Number goes on notehead side at middle note (or gap) of xtup, unless that */ +/* puts it in staff, then it flops to stem (or beam) side. */ +/* __ __ */ +/* | | | O | | */ +/* O | | O */ +/* |___| O |__| | */ + +/* iud -1 -1 1 1 ...stem direction */ +/* iflop 0 1 -1 0 ...direction of flop */ +/* iup -1 1 -1 1 ...direction of number and bracket */ + + iud = 1; + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u') + { + iud = -1; + } + +/* Get ip#, note level of middle note (or gap) in xtup */ + + ipmid = ipb1 + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25] / 2; + i__1 = ncmid_(&all_1.iv, &ipmid); + i__2 = (15 & all_1.mult[commvl_1.ivx + ipmid * 24 - 25]) - 8; + xnlmid = (real) levrn_(&all_1.nolev[commvl_1.ivx + ipmid * 24 - 25], & + all_1.irest[commvl_1.ivx + ipmid * 24 - 25], &iud, &i__1, & + i__2); + if (comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[commvl_1.ivx - 1] + * 24 - 25] % 2 == 0) { + i__2 = ipmid - 1; + i__1 = ncmid_(&all_1.iv, &i__2); + i__3 = (15 & all_1.mult[commvl_1.ivx + (ipmid - 1) * 24 - 25]) - + 8; + xnlmid = (xnlmid + levrn_(&all_1.nolev[commvl_1.ivx + (ipmid - 1) + * 24 - 25], &all_1.irest[commvl_1.ivx + (ipmid - 1) * 24 + - 25], &iud, &i__1, &i__3)) / 2; + } + iflop = 0; + if ((r__1 = xnlmid - ncmid_(&all_1.iv, &ipb1), dabs(r__1)) < 3.f) { + iflop = -iud; + } + iup = iud + (iflop << 1); + if (bit_test(all_1.irest[commvl_1.ivx + ipb1 * 24 - 25],14)) { + +/* Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) */ + + iup = -iup; + iflop = 0; + if (iud * iup < 0) { + iflop = iup; + } + } + +/* Determine if a beam is to be drawn */ + + i__1 = all_1.ibm2[commvl_1.ivx + ibc * 24 - 25]; + for (ipp = all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; ipp <= i__1; + ++ipp) { + if ((15 & all_1.mult[commvl_1.ivx + ipp * 24 - 25]) - 8 <= 0) { + comdraw_1.drawbm[commvl_1.ivx - 1] = FALSE_; + goto L6; + } +/* L5: */ + } + comdraw_1.drawbm[commvl_1.ivx - 1] = ! bit_test(all_1.islur[ + commvl_1.ivx + all_1.ibm1[commvl_1.ivx + ibc * 24 - 25] * 24 + - 25],18); +L6: + +/* Are we using tuplet.tex? */ + + usexnumt = comnvst_1.cstuplet && ! comdraw_1.drawbm[commvl_1.ivx - 1]; + +/* Place xtup number if needed */ + + if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31) || + multb <= 0) { + mprint = igetbits_(&all_1.nacc[commvl_1.ivx + ip * 24 - 25], & + c__5, &c__22); + if (mprint == 0) { + mprint = comxtup_1.mtupv[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25]; + } + i__1 = ncmid_(&all_1.iv, &ipb1); + putxtn_(&mprint, &iflop, &multb, &iud, &comask_1.wheadpt, & + comask_1.poenom, &comxtup_1.nolev1[commvl_1.ivx - 1], & + comxtup_1.islope[commvl_1.ivx - 1], &all_1.slfac, &xnlmid, + &all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], lnote, + notexq, &i__1, &nlnum, &comxtup_1.eloff[commvl_1.ivx + + comxtup_1.nxtinbm[commvl_1.ivx - 1] * 24 - 25], &iup, & + all_1.irest[commvl_1.ivx + ipb1 * 24 - 25], &usexnumt, ( + ftnlen)79); + } + if (! comdraw_1.drawbm[commvl_1.ivx - 1]) { + +/* Xtuplet with no beam */ + + if (! bit_test(all_1.islur[commvl_1.ivx + ipb1 * 24 - 25],31)) { + +/* Number printing has not been suppressed, so put in the bracket. */ +/* scale = stretch factor for bracket if there are asx's */ +/* xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) */ + + r__1 = space[*ib] / squez[*ib]; + xnsk = (comeskz2_1.eskz2[commvl_1.ivx + (ipb1 + + comxtup_1.ntupv[commvl_1.ivx + comxtup_1.nxtinbm[ + commvl_1.ivx - 1] * 24 - 25] - 1) * 24 - 25] - + comeskz2_1.eskz2[commvl_1.ivx + ipb1 * 24 - 25]) / + squez[*ib] / feon_(&r__1); + if (iup == 1) { + if (*lnote > 0) { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 5, a__1[2] = "ovbkt"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + } else { +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 5, a__2[1] = "ovbkt"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + } + } else { + if (*lnote > 0) { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 5, a__1[2] = "unbkt"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + } else { + +/* Introduced 12/5/98, req'd due to possible presence of in-line TeX */ + +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 5, a__2[1] = "unbkt"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + } + } + *lnote += 6; + if (all_1.iline == 1) { + comipb_1.smed /= 1.f - comtop_1.fracindent; + } + xslope = comipb_1.smed * 1.8f * all_1.slfac; + comxtup_1.islope[commvl_1.ivx - 1] = i_nint(&xslope); + r__1 = comipb_1.smed * comxtup_1.eloff[commvl_1.ivx - 1]; + comxtup_1.nolev1[commvl_1.ivx - 1] = nlnum - i_nint(&r__1); + if (comxtup_1.islope[commvl_1.ivx - 1] == 0) { + --comxtup_1.nolev1[commvl_1.ivx - 1]; + } + if (iup == 1) { + comxtup_1.nolev1[commvl_1.ivx - 1] += 4; + } + levbracket = comxtup_1.nolev1[commvl_1.ivx - 1]; + if (iup == 1 && comnvst_1.cstuplet) { + --levbracket; + } + i__1 = ncmid_(&all_1.iv, &ipb1); + notefq_(noteq, &lnoten, &levbracket, &i__1, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = lnoten, a__1[1] = noteq; + i__4[2] = 1, a__1[2] = "{"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote = *lnote + lnoten + 1; + if (xnsk < .995f) { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 4 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(i1,f3.2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); + e_wsfi(); + *lnote += 4; + } else if (xnsk < 9.995f) { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 4 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(f4.2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); + e_wsfi(); + *lnote += 4; + } else { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 5 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(f5.2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&xnsk, (ftnlen)sizeof(real)); + e_wsfi(); + *lnote += 5; + } +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + ++(*lnote); + if (bit_test(all_1.mult[commvl_1.ivx + ipb1 * 24 - 25],4)) { + +/* Tweak slope of bracket */ + + comxtup_1.islope[commvl_1.ivx - 1] = comxtup_1.islope[ + commvl_1.ivx - 1] + igetbits_(&all_1.mult[ + commvl_1.ivx + ipb1 * 24 - 25], &c__5, &c__5) - + 16; + } + if (comxtup_1.islope[commvl_1.ivx - 1] < 0 || + comxtup_1.islope[commvl_1.ivx - 1] >= 10) { +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = 1, a__2[1] = "{"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + ++(*lnote); + if (comxtup_1.islope[commvl_1.ivx - 1] < -9) { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 3 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(i3)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx + - 1], (ftnlen)sizeof(integer)); + e_wsfi(); + *lnote += 3; + } else { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 2 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(i2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx + - 1], (ftnlen)sizeof(integer)); + e_wsfi(); + *lnote += 2; + } +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + ++(*lnote); + } else { + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + 1 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(i1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], + (ftnlen)sizeof(integer)); + e_wsfi(); + ++(*lnote); + } + +/* Done with bracket */ + + } + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) { + +/* Put in the rest. Possible problem: Rest is a spacing char, but between */ +/* beamstrt and beamn1 some non-spacing chars. are inserted. */ + + if (multb == 0) { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "qp"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 1) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "ds"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 2) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "qs"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else if (! comdraw_1.drawbm[commvl_1.ivx - 1] && multb == 3) + { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 2, a__1[2] = "hs"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 3; + } else { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 6, a__1[2] = "hpause"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote += 7; + } + +/* No need to come back through this subroutine (as would if rest starts bar */ +/* & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. */ + + strtmid_1.ixrest[commvl_1.ivx - 1] = 0; + } + return 0; + } + +/* End if block for non-beamed xtup start...note we returned */ + + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 1) { + +/* Insert rest at start of beamed xtup. See above note for possible problem. */ + + i__1 = 4 - multb; + all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = pow_ii(&c__2, &i__1); + notex_(tempq, <emp, (ftnlen)79); + if (*lnote > 0) { +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = ltemp, a__2[1] = tempq; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + } else { + s_copy(notexq, tempq, (ftnlen)79, ltemp); + } + *lnote += ltemp; + +/* Re-zero just in case! */ + + all_1.nodur[commvl_1.ivx + ipb1 * 24 - 25] = 0; + ++all_1.ibm1[commvl_1.ivx + ibc * 24 - 25]; + +/* See if next note is a non-rest */ + + if (! bit_test(all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],0) + ) { + strtmid_1.ixrest[commvl_1.ivx - 1] = 2; + } else { + +/* Suppress reprinting xtup number next time through beamstrt */ + + all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set( + all_1.islur[commvl_1.ivx + (ipb1 + 1) * 24 - 25],31); + +/* Set new xtup start flag */ + + all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25] = bit_set( + all_1.irest[commvl_1.ivx + (ipb1 + 1) * 24 - 25],28); + } + return 0; + } + } + +/* Just ended if block for xtups */ + + if (comxtup_1.vxtup[commvl_1.ivx - 1] && ipb1 == all_1.ibm2[commvl_1.ivx + + ibc * 24 - 25]) { + +/* Move actual note writing to beamend */ + + strtmid_1.ixrest[commvl_1.ivx - 1] = 4; + return 0; + } + if (comxtup_1.issb[commvl_1.ivx - 1] == 0) { + +/* 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed */ + + iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, & + c__11) - 30; + if (iadj != -30) { + comxtup_1.nolev1[commvl_1.ivx - 1] += iadj; + i__1 = comxtup_1.nssb[commvl_1.ivx - 1]; + for (isssb = 1; isssb <= i__1; ++isssb) { + comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] += iadj; +/* L2: */ + } + } + iadj = igetbits_(&all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25], &c__6, & + c__17) - 30; + if (iadj != -30) { + comxtup_1.islope[commvl_1.ivx - 1] += iadj; + if ((i__1 = comxtup_1.islope[commvl_1.ivx - 1], abs(i__1)) > 9) { + comxtup_1.islope[commvl_1.ivx - 1] = i_sign(&c__9, & + comxtup_1.islope[commvl_1.ivx - 1]); + } + if (comxtup_1.nssb[commvl_1.ivx - 1] > 0) { + +/* Cycle thru non-rest notes in SSBG, looking for bmstrts. */ + + isssb = 0; + i__1 = comipb_1.nnb; + for (inb = 2; inb <= i__1; ++inb) { + if (bit_test(all_1.nacc[commvl_1.ivx + comipb_1.ipb[inb - + 1] * 24 - 25],21)) { + +/* Beam segment start. New start level */ + ++isssb; + comxtup_1.lev1ssb[commvl_1.ivx + isssb * 24 - 25] += + comxtup_1.islope[commvl_1.ivx - 1] * + comxtup_1.xelsk[inb - 1] / all_1.slfac; + } +/* L4: */ + } + } + } + } + iadj = igetbits_(&all_1.islur[commvl_1.ivx + ipb1 * 24 - 25], &c__2, & + c__27); + addbrack = FALSE_; + if (bit_test(all_1.ipl[commvl_1.ivx + ipb1 * 24 - 25],30)) { + +/* Check for altered starting polarity. Only in forced beams. Nominal start */ +/* level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). */ + + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'u' + && comxtup_1.nolev1[commvl_1.ivx - 1] + 6 < all_1.nolev[ + commvl_1.ivx + ipb1 * 24 - 25]) { + if (*lnote == 0) { +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 5, a__2[1] = "loff{"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 5, a__1[2] = "loff{"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + } + *lnote += 6; + addbrack = TRUE_; + } else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] + == 'l' && comxtup_1.nolev1[commvl_1.ivx - 1] - 6 > + all_1.nolev[commvl_1.ivx + ipb1 * 24 - 25]) { + if (*lnote == 0) { +/* Writing concatenation */ + i__5[0] = 1, a__2[0] = all_1.sq; + i__5[1] = 5, a__2[1] = "roff{"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = 1, a__1[1] = all_1.sq; + i__4[2] = 5, a__1[2] = "roff{"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + } + *lnote += 6; + addbrack = TRUE_; + } + +/* Check end level for possible flipping in forced beam. Have to do it */ +/* here since with multiple voices, xelsk will not be preserved. */ + + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25] == 'u') { + bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] + 6 + comxtup_1.islope[ + commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] / + all_1.slfac; + strtmid_1.flipend[commvl_1.ivx - 1] = bmlev < (real) all_1.nolev[ + commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] * + 24 - 25]; + } else if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + all_1.ibmcnt[ + commvl_1.ivx - 1] * 24 - 25] == 'l') { + bmlev = comxtup_1.nolev1[commvl_1.ivx - 1] - 6 + comxtup_1.islope[ + commvl_1.ivx - 1] * comxtup_1.xelsk[comipb_1.nnb - 1] / + all_1.slfac; + strtmid_1.flipend[commvl_1.ivx - 1] = bmlev > (real) all_1.nolev[ + commvl_1.ivx + all_1.ibm2[commvl_1.ivx + ibc * 24 - 25] * + 24 - 25]; + } + } + i__1 = multb + iadj; + ntrbbb_(&i__1, "i", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), & + commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, (ftnlen)79); + +/* Put in name of start level and slope, after correcting nolev1 if xtup */ +/* started with a rest. */ + + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) { + r__1 = comxtup_1.nolev1[commvl_1.ivx - 1] + comxtup_1.xelsk[0] * + comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac; + comxtup_1.nolev1[commvl_1.ivx - 1] = i_nint(&r__1); + } + i__1 = ncmid_(&all_1.iv, &ipb1); + notefq_(noteq, &lnoten, &comxtup_1.nolev1[commvl_1.ivx - 1], &i__1, ( + ftnlen)8); + if (comxtup_1.islope[commvl_1.ivx - 1] < 0) { +/* Writing concatenation */ + i__4[0] = *lnote, a__1[0] = notexq; + i__4[1] = lnoten, a__1[1] = noteq; + i__4[2] = 1, a__1[2] = "{"; + s_cat(notexq, a__1, i__4, &c__3, (ftnlen)79); + *lnote = *lnote + 4 + lnoten; + i__1 = *lnote - 3; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(i2,a1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen) + sizeof(integer)); + do_fio(&c__1, "}", (ftnlen)1); + e_wsfi(); + } else { +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = lnoten, a__2[1] = noteq; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + *lnote = *lnote + 1 + lnoten; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = 1; + ici__1.iciunit = notexq + (*lnote - 1); + ici__1.icifmt = "(i1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comxtup_1.islope[commvl_1.ivx - 1], (ftnlen) + sizeof(integer)); + e_wsfi(); + } + +/* Check for beam-thk fine-tuning */ + + if (iadj > 0) { + i__1 = multb + 1; + for (imp = multb + iadj; imp >= i__1; --imp) { + ntrbbb_(&imp, "t", all_1.ulq + (commvl_1.ivx + ibc * 24 - 25), & + commvl_1.ivx, notexq, lnote, (ftnlen)1, (ftnlen)1, ( + ftnlen)79); +/* L1: */ + } + } + +/* If we shifted, must close with right bracket */ + + if (addbrack) { +/* Writing concatenation */ + i__5[0] = *lnote, a__2[0] = notexq; + i__5[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__5, &c__2, (ftnlen)79); + ++(*lnote); + } + +/* Get 'floor' zmin for figures */ +/* Note: Will not come thru here on 1st note of unbeamed xtup, so figure height */ +/* won't be adjusted. If anyone ever needs that, need to duplicate this */ +/* functionality up above, before exiting. */ + + if (all_1.figbass && (commvl_1.ivx == 1 || commvl_1.ivx == + comfig_1.ivxfig2)) { + if (commvl_1.ivx == 1) { + ivf = 1; + } else { + ivf = comfig_1.ivxfig2; + } + zmult = (multb - 1) * 1.2f; + ymin = 100.f; + i__1 = comipb_1.nnb; + for (inb = 1; inb <= i__1; ++inb) { + if (all_1.isfig[ivf + (comipb_1.ipb[inb - 1] << 1) - 3]) { + if (*(unsigned char *)&all_1.ulq[all_1.iv + ibc * 24 - 25] == + 'u') { + ybot = (real) all_1.nolev[all_1.iv + comipb_1.ipb[inb - 1] + * 24 - 25]; + } else { + ybot = comxtup_1.islope[commvl_1.ivx - 1] / all_1.slfac * + comxtup_1.xelsk[inb - 1] + comxtup_1.nolev1[ + commvl_1.ivx - 1] - all_1.stemlen - zmult; + } + ymin = dmin(ymin,ybot); + } +/* L3: */ + } + maxdrop = ncmid_(&all_1.iv, &ipb1) - 4 - ymin + 5.01f; +/* Computing MAX */ + i__1 = all_1.ifigdr[ivf + (all_1.iline << 1) - 3]; + all_1.ifigdr[ivf + (all_1.iline << 1) - 3] = max(i__1,maxdrop); + } + +/* Compute ornament levels if needed */ + + nomornlev = ncmid_(&all_1.iv, &ipb1) + 5; + iorn = 0; + i__1 = comipb_1.nnb; + for (inb = 1; inb <= i__1; ++inb) { + ip = comipb_1.ipb[inb - 1]; + if (! bit_test(all_1.iornq[commvl_1.ivx + ip * 24 - 1],23)) { + goto L8; + } + if (bit_test(all_1.irest[commvl_1.ivx + ip * 24 - 25],26) && *( + unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == + 'l') { + +/* letter-dynamic or hairpin ending under down-beamed */ + + ++iorn; + ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] - all_1.stemlen + + comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[inb + - 1] / all_1.slfac + 1 - (multb - 1) * 1.2f; +/* Computing MIN */ + r__1 = ybeam - 3.f; + i__2 = i_nint(&r__1), i__3 = nomornlev - 10; + ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3); + } else if (! bit_test(all_1.ipl[commvl_1.ivx + ip * 24 - 25],10)) { + +/* Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F */ +/* 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD */ + +/* Non-chord. There IS an ornament. Need ihornb only if upbeam, and if */ +/* ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) */ + + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == + 'u' && (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] * + 24 - 1] & 4163566) > 0) { + ++iorn; + all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set(all_1.iornq[ + commvl_1.ivx + ip * 24 - 1],22); + ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] + all_1.stemlen + + comxtup_1.islope[commvl_1.ivx - 1] * comxtup_1.xelsk[ + inb - 1] / all_1.slfac - 1 + (multb - 1) * 1.2f; +/* Computing MAX */ + r__1 = ybeam + 3.f; + i__2 = i_nint(&r__1); + ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev); + } + } else { + +/* In a chord. Orn may be on main note or non-main or both. Set ihornb if */ +/* upbeam and highest note has orn, or down beam and lowest. Find 1st chord note */ + + i__2 = comtrill_1.ncrd; + for (comtrill_1.icrd1 = 1; comtrill_1.icrd1 <= i__2; + ++comtrill_1.icrd1) { + if ((255 & comtrill_1.icrdat[comtrill_1.icrd1 - 1]) == ip && ( + 15 & lbit_shift(comtrill_1.icrdat[comtrill_1.icrd1 - + 1], (ftnlen)-8)) == commvl_1.ivx) { + goto L11; + } +/* L10: */ + } +L11: + +/* Find outermost note, min or max depending on beam direction ulq. xto is true */ +/* if there's an ornament on that note. Expand orn list to include ._, since if */ +/* on extreme chord note in beam, will move. */ +/* So ornaments are all except 0,4,13 (,g,) */ + + levx = all_1.nolev[commvl_1.ivx + ip * 24 - 25]; + xto = (all_1.iornq[commvl_1.ivx + comipb_1.ipb[inb - 1] * 24 - 1] + & 4186094) > 0; + icrdx = 0; + i__2 = comtrill_1.ncrd; + for (icrd = comtrill_1.icrd1; icrd <= i__2; ++icrd) { + if ((255 & comtrill_1.icrdat[icrd - 1]) != ip || (15 & + lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen)-8)) + != commvl_1.ivx) { + goto L13; + } + levc = 127 & lbit_shift(comtrill_1.icrdat[icrd - 1], (ftnlen) + -12); + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] + == 'u' && levc > levx || *(unsigned char *)& + all_1.ulq[commvl_1.ivx + ibc * 24 - 25] == 'l' && + levc < levx) { + levx = levc; + icrdx = icrd; + xto = (comtrill_1.icrdorn[icrd - 1] & 4186094) > 0; + } +/* L12: */ + } +L13: + +/* If there's orn on extreme note, do stuff */ + + if (xto) { + ++iorn; + if (*(unsigned char *)&all_1.ulq[commvl_1.ivx + ibc * 24 - 25] + == 'u') { + ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] + + all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1] + * comxtup_1.xelsk[inb - 1] / all_1.slfac - 1 + ( + multb - 1) * 1.2f; +/* Computing MAX */ + r__1 = ybeam + 3.f; + i__2 = i_nint(&r__1); + ihornb[commvl_1.ivx + iorn * 24] = max(i__2,nomornlev); + } else { + ybeam = comxtup_1.nolev1[commvl_1.ivx - 1] - + all_1.stemlen + comxtup_1.islope[commvl_1.ivx - 1] + * comxtup_1.xelsk[inb - 1] / all_1.slfac + 1 - ( + multb - 1) * 1.2f; +/* Computing MIN */ + r__1 = ybeam - 3.f; + i__2 = i_nint(&r__1), i__3 = nomornlev - 10; + ihornb[commvl_1.ivx + iorn * 24] = min(i__2,i__3); + } + if (icrdx == 0) { + +/* Affected ornament is on main note */ + + all_1.iornq[commvl_1.ivx + ip * 24 - 1] = bit_set( + all_1.iornq[commvl_1.ivx + ip * 24 - 1],22); + } else { + comtrill_1.icrdorn[icrdx - 1] = bit_set( + comtrill_1.icrdorn[icrdx - 1],22); + } + } + } +L8: + ; + } + +/* Henceforth nornb will be a counter. */ + + if (iorn > 0) { + nornb[commvl_1.ivx] = 1; + } + if (strtmid_1.ixrest[commvl_1.ivx - 1] == 2) { + strtmid_1.ixrest[commvl_1.ivx - 1] = 0; + } + return 0; +} /* beamstrt_ */ + + + +/* meter space (pts) = xb4mbr = musicsize*facmtr */ + + +/* From other */ + +/* * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, */ + +/* Subroutine */ int catspace_(real *space, real *squez, integer *nnsk) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + static integer iptr; + + i__1 = c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1; + for (iptr = c1omnotes_1.nptr[c1omnotes_1.ibarcnt - 1]; iptr <= i__1; + ++iptr) { + if ((r__1 = *space - c1omnotes_1.durb[iptr - 1], dabs(r__1)) < + comtol_1.tol) { + if ((r__1 = *squez - c1omnotes_1.sqzb[iptr - 1], dabs(r__1)) < + comtol_1.tol) { + +/* Increment pre-existing entry */ + + c1omnotes_1.nnpd[iptr - 1] += *nnsk; + return 0; + } + } +/* L16: */ + } + +/* Didn't find current duration & squez, so add a new entry. */ +/* No particular reason to keep in order, so add at the end. */ + + c1omnotes_1.nnpd[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *nnsk; + c1omnotes_1.durb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *space; + c1omnotes_1.sqzb[c1omnotes_1.nptr[c1omnotes_1.ibarcnt] - 1] = *squez; + ++c1omnotes_1.nptr[c1omnotes_1.ibarcnt]; + return 0; +} /* catspace_ */ + +/* Character */ VOID chax_(char *ret_val, ftnlen ret_val_len, integer *n) +{ + +/* The only reason for this seemingly do-nothing function is to get around an */ +/* apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! */ + + *(unsigned char *)ret_val = (char) (*n); + return ; +} /* chax_ */ + +/* Subroutine */ int checkdyn_(char *lineq, integer *iccount, integer *ibar, + ftnlen lineq_len) +{ + /* System generated locals */ + address a__1[3]; + integer i__1, i__2[3], i__3; + real r__1; + char ch__1[4], ch__2[1]; + icilist ici__1; + + /* Builtin functions */ + integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *, + ftnlen, ftnlen); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void) + , i_nint(real *); + + /* Local variables */ + static integer ipm, iend; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer idno; + static real fnum; + static char durq[1]; + extern /* Subroutine */ int stop1_(void), errmsg_(char *, integer *, + integer *, char *, ftnlen, ftnlen); + static logical txtdyn; + extern /* Subroutine */ int readnum_(char *, integer *, char *, real *, + ftnlen, ftnlen); + static char dynsymq[4]; + + txtdyn = FALSE_; + +/* On entry, iccount is on "D" */ + + i__1 = *iccount; + if (s_cmp(lineq + i__1, "\"", *iccount + 1 - i__1, (ftnlen)1) == 0) { + +/* Dynamic text */ + + i__1 = *iccount + 1; + iend = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1); + if (iend == 0) { + i__1 = *iccount + 1; + errmsg_(lineq, &i__1, ibar, "Dynamic text must be terminated wit" + "h double quote!", (ftnlen)128, (ftnlen)50); + stop1_(); + } + +/* Set iccount to character after 2nd ", and set ipm */ + + *iccount = *iccount + iend + 2; + ipm = i_indx("- +", lineq + (*iccount - 1), (ftnlen)3, (ftnlen)1); + if (ipm == 0) { + errmsg_(lineq, iccount, ibar, "Expected \"-\", \"+\", or blank h" + "ere!", (ftnlen)128, (ftnlen)33); + stop1_(); + } + } else { + +/* Expect ordinary dynamic */ + + for (iend = *iccount + 2; iend <= 128; ++iend) { + ipm = i_indx("- +", lineq + (iend - 1), (ftnlen)3, (ftnlen)1); + if (ipm > 0) { + goto L2; + } +/* L1: */ + } +L2: + if (iend - *iccount > 5 || iend - *iccount < 2) { + i__1 = iend - 1; + errmsg_(lineq, &i__1, ibar, "Wrong length for dynamic mark!", ( + ftnlen)128, (ftnlen)30); + stop1_(); + } + i__1 = *iccount; + ici__1.icierr = 0; + ici__1.iciend = 0; + ici__1.icirnum = 1; + ici__1.icirlen = iend - 1 - i__1; + ici__1.iciunit = lineq + i__1; +/* Writing concatenation */ + i__2[0] = 2, a__1[0] = "(a"; + i__3 = iend + 47 - *iccount; + chax_(ch__2, (ftnlen)1, &i__3); + i__2[1] = 1, a__1[1] = ch__2; + i__2[2] = 1, a__1[2] = ")"; + ici__1.icifmt = (s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)4), ch__1); + s_rsfi(&ici__1); + do_fio(&c__1, dynsymq, (ftnlen)4); + e_rsfi(); + idno = (i_indx("ppppppp pp p mp mf f fp sfz ff fff ffff< " + "> ", dynsymq, (ftnlen)56, (ftnlen)4) + 3) / 4; + if (idno == 0) { + i__1 = *iccount + 1; + errmsg_(lineq, &i__1, ibar, "Illegal dynamic mark!", (ftnlen)128, + (ftnlen)21); + stop1_(); + } + *iccount = iend; + } + if (ipm != 2) { + +/* There is a vertical shift, have "+" or "-" */ + + ++(*iccount); + if (i_indx("0123456789", lineq + (*iccount - 1), (ftnlen)10, (ftnlen) + 1) == 0) { + errmsg_(lineq, iccount, ibar, "Expected integer here for vertica" + "l offset!", (ftnlen)128, (ftnlen)42); + stop1_(); + } + readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); + idno = i_nint(&fnum); + if (idno > 63) { + i__1 = *iccount - 1; + errmsg_(lineq, &i__1, ibar, "Vertical offset for dynamic mark mu" + "st be (-63,63)!", (ftnlen)128, (ftnlen)50); + stop1_(); + } + ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1); + if (ipm == 0) { + errmsg_(lineq, iccount, ibar, "Expected \"+\", \"-\", or blank h" + "ere!", (ftnlen)128, (ftnlen)33); + stop1_(); + } + if (ipm != 2) { + +/* There is a horizontal shift */ + + ++(*iccount); + if (i_indx(".0123456789", lineq + (*iccount - 1), (ftnlen)11, ( + ftnlen)1) == 0) { + errmsg_(lineq, iccount, ibar, "Expected number here for hori" + "zontal offset!", (ftnlen)128, (ftnlen)43); + stop1_(); + } + readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); + r__1 = fnum * 10; + idno = i_nint(&r__1); + if (idno > 255) { + i__1 = *iccount - 1; + errmsg_(lineq, &i__1, ibar, "Horizontal offset for dynamic m" + "ark must be (-25.5,25.5)!", (ftnlen)128, (ftnlen)56); + stop1_(); + } else if (*(unsigned char *)durq != ' ') { + errmsg_(lineq, iccount, ibar, "There should be a blank here!", + (ftnlen)128, (ftnlen)29); + stop1_(); + } + } + +/* iccount should be on the blank at the end of the entire symbol */ + + } + return 0; +} /* checkdyn_ */ + +/* Subroutine */ int chkarp_(integer *ncrd, integer *icrdat, integer *ivx, + integer *ip, logical *iscacc, logical *isarp) +{ + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + integer lbit_shift(integer, integer); + + /* Local variables */ + static integer icrd; + static logical found1; + +/* subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, */ +/* * icashft) */ + /* Parameter adjustments */ + --icrdat; + + /* Function Body */ + found1 = FALSE_; + +/* icashft will be max left shift of accid's in chord notes. */ +/* Used only for spacing checks. */ +/* Will include left shift of chord note itself. */ +/* Rezero after use. */ + + i__1 = *ncrd; + for (icrd = 1; icrd <= i__1; ++icrd) { + +/* This if block cycles thru all chord notes on ivx,ip; then returns. */ + + if ((255 & icrdat[icrd]) == *ip && (15 & lbit_shift(icrdat[icrd], ( + ftnlen)-8)) == *ivx) { + found1 = TRUE_; + *iscacc = *iscacc || bit_test(icrdat[icrd],19) && ! bit_test( + icrdat[icrd],27); + +/* Accid on this chord note, and it's not midi-only. */ + +/* irshft = igetbits(icrdot(icrd),7,20) */ +/* c */ +/* c Include increment for notehead shift */ +/* c */ +/* if (btest(icrdat(icrd),23)) then */ +/* if (irshft .eq. 0) then */ +/* irshft = 44 */ +/* else */ +/* irshft=irshft-20 */ +/* end if */ +/* end if */ +/* if (irshft .ne. 0) then */ +/* c */ +/* c Accid on chord note is shifted. Include only left shift, in 20ths. */ +/* c */ +/* if (irshft .lt. 64) icashft = max(icashft,64-irshft) */ +/* end if */ +/* end if */ + *isarp = *isarp || bit_test(icrdat[icrd],25); + } else if (found1) { + return 0; + } +/* L18: */ + } + return 0; +} /* chkarp_ */ + +/* Subroutine */ int chkimidi_(integer *icm) +{ + /* Builtin functions */ + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + e_wsfe(void); + + /* Fortran I/O blocks */ + static cilist io___231 = { 0, 6, 0, 0, 0 }; + static cilist io___232 = { 0, 6, 0, 0, 0 }; + static cilist io___233 = { 0, 6, 0, "(a6,2x,4i8)", 0 }; + + + if (commidi_1.imidi[*icm] >= 24576) { + s_wsle(&io___231); + e_wsle(); + s_wsle(&io___232); + do_lio(&c__9, &c__1, "Midi file is too long! It will be corrupted or" + " worse", (ftnlen)52); + e_wsle(); + s_wsfe(&io___233); + do_fio(&c__1, "imidi:", (ftnlen)6); + do_fio(&c__1, (char *)&commidi_1.imidi[0], (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&commidi_1.imidi[1], (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&commidi_1.imidi[2], (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&commidi_1.imidi[3], (ftnlen)sizeof(integer)); + e_wsfe(); + } + return 0; +} /* chkimidi_ */ + +/* Subroutine */ int chklit_(char *lineq, integer *iccount, integer *literr, + ftnlen lineq_len) +{ + /* System generated locals */ + char ch__1[1]; + + /* Local variables */ + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static char charq[1]; + static integer itype, lenlit; + extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen, + ftnlen); + + *literr = 0; + itype = 1; +L17: + g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); + chax_(ch__1, (ftnlen)1, &c__92); + if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) { + ++itype; +/* if (itype .eq. 2) then */ +/* if (iccount .ne. 2 ) then */ +/* c */ +/* c type 2 or 3 tex string not starting in column 1 */ +/* c */ +/* literr = 3 */ +/* return */ +/* end if */ +/* else if (itype .gt. 3) then */ + if (itype > 3) { + *literr = 1; + return 0; + } + goto L17; + } + lenlit = itype; +L18: + g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); + chax_(ch__1, (ftnlen)1, &c__92); + if (*(unsigned char *)charq == *(unsigned char *)&ch__1[0]) { + g1etchar_(lineq, iccount, charq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)charq != ' ') { + +/* Starting a new tex command withing the string */ + + lenlit += 2; + if (lenlit > 128) { + *literr = 2; + return 0; + } + goto L18; + } + } else { + ++lenlit; + if (lenlit > 128) { + *literr = 2; + return 0; + } + goto L18; + } + return 0; +} /* chklit_ */ + +/* Subroutine */ int chkpm4ac_(char *lineq, integer *iccount, integer *nacc, + logical *moved, ftnlen lineq_len) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1; + + /* Builtin functions */ + integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *, + ftnlen, ftnlen), i_nint(real *); + + /* Local variables */ + static integer ipm; + static real fnum; + static char durq[1]; + static integer icsav; + static logical ishorz; + extern /* Subroutine */ int readnum_(char *, integer *, char *, real *, + ftnlen, ftnlen), setbits_(integer *, integer *, integer *, + integer *); + + +/* Called after getting +/-/ in a note (not rest). iccount is on the +-<>. */ +/* Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits */ +/* 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed */ +/* numbers. If moved=.true., iccount on exit is on end of last number. */ +/* If moved=.false., iccount still on +/- */ + + i__1 = *iccount - 2; + i__2 = *iccount; + if (i_indx("sfnA", lineq + i__1, (ftnlen)4, *iccount - 1 - i__1) > 0 && + i_indx("0123456789.", lineq + i__2, (ftnlen)11, *iccount + 1 - + i__2) > 0) { + +/* Prior char was accid & next is #; this may be start of accidental shift. */ +/* Must test for "." above in case we get "<" or ">" */ + + ipm = i_indx("- +< >", lineq + (*iccount - 1), (ftnlen)6, (ftnlen)1) + - 2; + i__1 = *iccount + 1; + i__2 = *iccount; + if (s_cmp(lineq + i__2, ".", *iccount + 1 - i__2, (ftnlen)1) == 0 && + i_indx("0123456789", lineq + i__1, (ftnlen)10, *iccount + 2 - + i__1) == 0) { + +/* Rare case of [accid][+/-].[letter]. Bail out */ + + *moved = FALSE_; + return 0; + } + ishorz = ipm > 1; + +/* Save iccount in case it's not accid shift and we have to reset. */ + + icsav = *iccount; + ++(*iccount); + readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); + if (ishorz || i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* This has to be accidental shift. Set vert. shift. */ + + if (! ishorz) { + +/* +/- syntax, both shifts set, vertical first */ + + i__1 = (integer) (ipm * fnum + 32.5f); + setbits_(nacc, &c__6, &c__4, &i__1); + ipm = i_indx("- +", durq, (ftnlen)3, (ftnlen)1) - 2; + ++(*iccount); + readnum_(lineq, iccount, durq, &fnum, (ftnlen)128, (ftnlen)1); + } else { + +/* syntax, only horiz set */ + + ipm += -3; + } + +/* Set horiz. shift */ + + r__1 = (ipm * fnum + 5.35f) * 20; + i__1 = i_nint(&r__1); + setbits_(nacc, &c__7, &c__10, &i__1); + --(*iccount); + *moved = TRUE_; + } else { + +/* False alarm. Reset everything and flow onward */ + + *moved = FALSE_; + *iccount = icsav; + } + } else { + +/* Either prior char was not 'sfn' or next was not digit, so take no action */ + + *moved = FALSE_; + } + return 0; +} /* chkpm4ac_ */ + +/* Subroutine */ int clefsym_(integer *isl, char *notexq, integer *lnote, + integer *nclef, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[4]; + integer i__1[4], i__2, i__3; + char ch__1[1], ch__2[1], ch__3[1]; + + /* Builtin functions */ + integer lbit_shift(integer, integer); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + + /* Local variables */ + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer nlev; + + +/* Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. */ + + *nclef = lbit_shift(*isl, (ftnlen)-12) & 7; + if (*nclef == 0) { + +/* treble */ + + nlev = 2; + } else if (*nclef > 6) { + +/* French violin */ + + nlev = 0; + } else if (*nclef < 5) { + +/* C-clef */ + + nlev = (*nclef << 1) - 2; + } else { + +/* F-clef */ + + nlev = (*nclef << 1) - 6; + } +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__1[0] = 1, a__1[0] = ch__1; + i__1[1] = 7, a__1[1] = "pmxclef"; + i__2 = min(*nclef,7) + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__1[2] = 1, a__1[2] = ch__2; + i__3 = nlev + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__1[3] = 1, a__1[3] = ch__3; + s_cat(notexq, a__1, i__1, &c__4, notexq_len); + *lnote = 10; + return 0; +} /* clefsym_ */ + +/* Subroutine */ int crdacc_(integer *nacc, integer *naccid, integer *micrd, + integer *nolevm, real *rmsshift, logical *lasttime, integer * + levmaxacc, integer *icrdot0, real *segrb0, integer *ksegrb0, integer * + nsegrb0, logical *twooftwo, integer *icashft) +{ + /* Initialized data */ + + static integer nsegar[5] = { 3,4,3,3,2 }; + static integer nsegal[5] = { 2,4,3,3,2 }; + static real segar[60] /* was [5][2][6] */ = { -.05f,-.38f,-.34f, + -.05f,-.15f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,-.75f,-.2f,-.8f,-.75f, + 0.f,.96f,-1.04f,1.48f,.96f,1.2f,0.f,-.38f,0.f,0.f,0.f,3.15f,1.64f, + 3.f,3.15f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f,0.f, + 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f, + 0.f,0.f }; + static real segal[60] /* was [5][2][6] */ = { -1.f,-1.02f,-.6f, + -1.65f,-1.2f,-1.4f,-2.9f,-3.f,-1.4f,-1.2f,0.f,-1.2f,-1.04f,0.f, + 0.f,3.15f,-1.64f,-1.48f,3.15f,1.2f,0.f,-1.02f,0.f,0.f,0.f,0.f, + 1.04f,3.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,2.9f,0.f,0.f,0.f,0.f, + 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f, + 0.f,0.f,0.f }; + static integer iacctbl[6] = { 1,2,3,0,4,5 }; + + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + + /* Builtin functions */ + integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, + char *, ftnlen), e_wsle(void); + + /* Local variables */ + static integer iacctype; + static logical mainnote; + extern integer igetbits_(integer *, integer *, integer *); + static real ybotaseg, shiftmin; + static integer isetshft[10]; + static real ytopaseg; + static integer ibelowbot, ibelowtop, iwa, iranksetter, iseg; + extern /* Subroutine */ int stop1_(void); + static integer isega; + static real segrb[100] /* was [2][50] */; + static integer irank; + static real shift; + static integer nolev, isegrb, ksegrb[50], nsegrb, ishift; + extern /* Subroutine */ int printl_(char *, ftnlen); + static integer netgain; + extern /* Subroutine */ int setbits_(integer *, integer *, integer *, + integer *); + + /* Fortran I/O blocks */ + static cilist io___268 = { 0, 6, 0, 0, 0 }; + static cilist io___269 = { 0, 6, 0, 0, 0 }; + + + +/* nacc = accidental bitmap for main note */ +/* naccid = # of accid's in chord */ +/* micrd = array with icrd #'s for notes w/ acc's, 0=>main note */ +/* nolevm = level of main note */ +/* segrb(1|2,.) x|y-coord of right-bdry segment */ +/* ksegrb(.) internal use; tells what defined this segment */ +/* -2: Left-shifted notehead */ +/* -1: Original right boundary */ +/* 0: Main note accidental */ +/* icrd: Chord-note accidental */ +/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */ +/* icrdot0 = top-down level-rank of main note among accid-notes */ +/* icrdot(icrd)(27-29) = level rank of chord-note among accid-notes */ +/* twooftwo will be true 2nd time thru; signal to store shifts w/ notes */ + + /* Parameter adjustments */ + --ksegrb0; + segrb0 -= 3; + --micrd; + + /* Function Body */ + +/* Fancy sharp boundary. fl,sh,na,dfl,dsh */ + +/* * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , */ +/* meas value for y, natural is 1.6 */ +/* * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , */ +/* c (meas. value is 3.08) ^^^^ */ +/* c Raise top of flat so it interferes with bottom of sharp */ + +/* iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) */ + + +/* Set up barrier segrb(iseg,ipoint) to define coords of corner points */ +/* on stem+notes */ + + i__1 = *nsegrb0; + for (iseg = 1; iseg <= i__1; ++iseg) { + segrb[(iseg << 1) - 2] = segrb0[(iseg << 1) + 1]; + segrb[(iseg << 1) - 1] = segrb0[(iseg << 1) + 2]; + ksegrb[iseg - 1] = ksegrb0[iseg]; +/* L11: */ + } + nsegrb = *nsegrb0; + *rmsshift = 0.f; + shiftmin = 1e3f; + i__1 = *naccid; + for (iwa = 1; iwa <= i__1; ++iwa) { + +/* Initialize shift for this note */ + + shift = 0.f; + mainnote = micrd[iwa] == 0; + isetshft[iwa - 1] = -1; + +/* Get note level and accidental type */ + + if (mainnote) { + nolev = *nolevm; + iacctype = iacctbl[igetbits_(nacc, &c__3, &c__0) - 1]; + } else { + nolev = igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], &c__7, & + c__12); + iacctype = iacctbl[igetbits_(&comtrill_1.icrdat[micrd[iwa] - 1], & + c__3, &c__20) - 1]; + } + +/* Cycle thru segments on right edge of this accidental */ + + i__2 = nsegar[iacctype - 1] - 1; + for (isega = 1; isega <= i__2; ++isega) { + ybotaseg = nolev + segar[iacctype + ((isega << 1) + 2) * 5 - 16]; + ytopaseg = nolev + segar[iacctype + ((isega + 1 << 1) + 2) * 5 - + 16]; + +/* Cycle thru segments of right-hand barrier */ + + i__3 = nsegrb - 1; + for (isegrb = 1; isegrb <= i__3; ++isegrb) { + +/* Must find all barrier segments that start below ytopseg & end above ybotseg */ + + if (segrb[(isegrb << 1) - 1] < ytopaseg) { + +/* Barrier seg starts below top of accid */ +/* Check if barrier seg ends above bottom of accid */ + + if (segrb[(isegrb + 1 << 1) - 1] > ybotaseg) { + if (shift > segrb[(isegrb << 1) - 2] - segar[iacctype + + ((isega << 1) + 1) * 5 - 16]) { + shift = segrb[(isegrb << 1) - 2] - segar[iacctype + + ((isega << 1) + 1) * 5 - 16]; + +/* Record the cause of the shift */ + + isetshft[iwa - 1] = ksegrb[isegrb - 1]; + } + } + +/* Does barrier segment end above top of accid seg? */ + + if (segrb[(isegrb + 1 << 1) - 1] > ytopaseg) { + goto L4; + } + } +/* L3: */ + } +L4: +/* L2: */ + ; + } + if (! bit_test(*nacc,28) && dabs(shift) > 1e-4f && ! (*lasttime)) { +/* if (nolev .eq. levmaxacc) then */ + if (nolev == *levmaxacc && isetshft[iwa - 1] == -1) { + *rmsshift = 1e3f; + return 0; + } + +/* Does the following properly account for left-shifted noteheads? */ + +/* Top-down rank of this note we just shifted */ + + if (mainnote) { + irank = *icrdot0; + } else { + irank = igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__3, & + c__27); + } + +/* Compare level-rank of this note vs. that of note that caused the shift. */ +/* This has effect of checking for basic interferences from top down. */ + +/* ksegrb(.) internal use; tells what defined this segment */ +/* -2: Left-shifted notehead */ +/* -1: Original right boundary */ +/* 0: Main note accidental */ +/* icrd: Chord-note accidental */ +/* isetshft(i),i=1,naccid: what set shift for this accid, same codes */ + + if (isetshft[iwa - 1] < 0) { + iranksetter = 0; + } else if (isetshft[iwa - 1] == 0) { + iranksetter = *icrdot0; + } else { + iranksetter = igetbits_(&comtrill_1.icrdot[isetshft[iwa - 1] + - 1], &c__3, &c__27); + } + if (iranksetter != 0 && irank != iranksetter + 1) { + *rmsshift = 1e3f; + return 0; + } + } +/* Computing 2nd power */ + r__1 = shift; + *rmsshift += r__1 * r__1; + if (*lasttime && dabs(shift) > 1e-4f) { + if (mainnote) { + if (! bit_test(*nacc,29)) { + goto L10; + } + } else { + if (! bit_test(comtrill_1.icrdat[micrd[iwa] - 1],29)) { + goto L10; + } + } + +/* If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there */ +/* was a manual shift but auto-shift was zero, will not come thru here, but shift value */ +/* will be left intact. */ + + if (mainnote) { + shift += (igetbits_(nacc, &c__7, &c__10) - 107) * .05f; + } else { + shift += (igetbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7, + &c__20) - 107) * .05f; + } +L10: + if (*twooftwo) { + +/* Record the shift for this accidental */ + + if (shift < -5.35f) { + printl_(" ", (ftnlen)1); + printl_("WARNING: auto-generated accidental shift too bi" + "g for PMX, ignoring", (ftnlen)66); + } else { + r__1 = (shift + 5.35f) * 20; + ishift = i_nint(&r__1); + if (mainnote) { + setbits_(nacc, &c__7, &c__10, &ishift); + } else { + setbits_(&comtrill_1.icrdot[micrd[iwa] - 1], &c__7, & + c__20, &ishift); + } + } + } else { + +/* This is the earlier call to precrd, so need minimum shift */ + + shiftmin = dmin(shiftmin,shift); + } + } + +/* Bail out if this is the last accidental to check */ + + if (iwa == *naccid) { + goto L1; + } + +/* Add this accidental to the right barrier! Count down from highest barrier segment, */ +/* find 1st one starting below top of accid, and first one starting below bot. */ + + for (ibelowtop = nsegrb; ibelowtop >= 1; --ibelowtop) { + if (segrb[(ibelowtop << 1) - 1] < nolev + segal[iacctype + (( + nsegal[iacctype - 1] << 1) + 2) * 5 - 16]) { + for (ibelowbot = ibelowtop; ibelowbot >= 1; --ibelowbot) { + if (segrb[(ibelowbot << 1) - 1] < nolev + segal[iacctype + + 4]) { + goto L6; + } +/* L9: */ + } + s_wsle(&io___268); + do_lio(&c__9, &c__1, "Oops2!", (ftnlen)6); + e_wsle(); + stop1_(); + } +/* L5: */ + } + s_wsle(&io___269); + do_lio(&c__9, &c__1, "Ugh0! in crdaccs", (ftnlen)16); + e_wsle(); + stop1_(); +L6: + netgain = nsegal[iacctype - 1] - ibelowtop + ibelowbot; + +/* Shift high segments up */ + + if (netgain >= 0) { + i__2 = ibelowtop + 1; + for (isegrb = nsegrb; isegrb >= i__2; --isegrb) { + segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2]; + segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1]; + ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1]; +/* L7: */ + } + +/* Set up 1st segment above accid */ + + segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) - + 2]; + segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + ( + (nsegal[iacctype - 1] << 1) + 2) * 5 - 16]; + ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1]; + } else { + +/* netgain<0, must remove segments. Use same coding but reverse order, */ +/* work from bottom up */ + + segrb[(ibelowtop + netgain << 1) - 2] = segrb[(ibelowtop << 1) - + 2]; + segrb[(ibelowtop + netgain << 1) - 1] = nolev + segal[iacctype + ( + (nsegal[iacctype - 1] << 1) + 2) * 5 - 16]; + ksegrb[ibelowtop + netgain - 1] = ksegrb[ibelowtop - 1]; + i__2 = nsegrb; + for (isegrb = ibelowtop + 1; isegrb <= i__2; ++isegrb) { + segrb[(isegrb + netgain << 1) - 2] = segrb[(isegrb << 1) - 2]; + segrb[(isegrb + netgain << 1) - 1] = segrb[(isegrb << 1) - 1]; + ksegrb[isegrb + netgain - 1] = ksegrb[isegrb - 1]; +/* L12: */ + } + } + +/* Insert new segments */ + + i__2 = nsegal[iacctype - 1] - 1; + for (isega = 1; isega <= i__2; ++isega) { + segrb[(ibelowbot + isega << 1) - 2] = shift + segal[iacctype + (( + isega << 1) + 1) * 5 - 16]; + segrb[(ibelowbot + isega << 1) - 1] = nolev + segal[iacctype + (( + isega << 1) + 2) * 5 - 16]; + if (mainnote) { + ksegrb[ibelowbot + isega - 1] = 0; + } else { + ksegrb[ibelowbot + isega - 1] = micrd[iwa]; + } +/* L8: */ + } + +/* Update number of barrier segments */ + + nsegrb += netgain; +/* c */ +/* c Temporary printout for boundary segments as built up */ +/* c */ +/* write(15,'()') */ +/* write(15,'(a/(2f8.2,i5))')' y x kseg', */ +/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */ +/* write(15,'(a/(2i5))')' micrd isetshft', */ +/* * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) */ +/* c */ +L1: + ; + } +/* next accidental */ + if (*lasttime && ! (*twooftwo)) { + +/* This is the final call on the pre-ask pass, so compute left-shift rqmt. */ + + r__1 = shiftmin * -20; + *icashft = i_nint(&r__1); + } +/* c */ +/* c Temporary printout for boundary segments */ +/* c */ +/* if (twooftwo) then */ +/* write(15,'()') */ +/* write(15,'(a/(2f8.2,i5))')' y x kseg', */ +/* * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) */ +/* write(15,'(a/(2i5))')' micrd isetshft', */ +/* * (micrd(iwa),isetshft(iwa),iwa=1,naccid) */ +/* end if */ +/* c */ + return 0; +} /* crdacc_ */ + +/* Subroutine */ int crdaccs_(integer *nacc, integer *ipl, integer *irest, + integer *naccid, integer *kicrd, integer *nolevm, integer *levmaxacc, + integer *levminacc, integer *icrdot0, logical *twooftwo, integer * + icashft) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + + /* Local variables */ + extern integer igetbits_(integer *, integer *, integer *); + static integer ipermsav[7]; + static real rmsshift; + static integer i__, j, k, levmidacc, ip, ir, is, it, maxmanshft, icrd; + extern /* Subroutine */ int stop1_(void); + static integer micrd[10], iiseg, irank, iperm[7], nolev; + static real segrb0[100] /* was [2][50] */; + extern /* Subroutine */ int crdacc_(integer *, integer *, integer *, + integer *, real *, logical *, integer *, integer *, real *, + integer *, integer *, logical *, integer *); + static logical tagged; + static integer isegrb; + static logical manual, lshift; + static integer idummy; + static real rmsmin; + static integer ksegrb0[50], nsegrb0, manshft; + extern /* Subroutine */ int setbits_(integer *, integer *, integer *, + integer *); + + /* Fortran I/O blocks */ + static cilist io___298 = { 0, 6, 0, 0, 0 }; + + + +/* nacc = accidental bitmap for main note */ +/* naccid = # of accid's in chord */ +/* kicrd = array with icrd #'s for notes w/ acc's, 0=>main note */ +/* nolevm = level of main note */ + +/* This is called once per multi-accidental chord. In here, loop over all */ +/* permutations of the order of accidental as stored in kicrd. Each time thru */ +/* loop, call crdacc once, get rms shift. Only save permutation and rms value */ +/* if it is less than old value. */ + + +/* Make consistent? 120106 */ +/* integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) */ +/* c */ +/* c Temporary printout of level-rankings */ +/* c */ +/* write(15,'()') */ +/* do 98 iacc = 1 , naccid */ +/* if (kicrd(iacc) .eq. 0) then */ +/* write(15,'(3i5)')nolevm,icrdot0 */ +/* else */ +/* write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), */ +/* * igetbits(icrdot(kicrd(iacc)),3,27) */ +/* end if */ +/* 98 continue */ +/* c */ + +/* Initialize right-barrier */ + + /* Parameter adjustments */ + --kicrd; + + /* Function Body */ + segrb0[0] = 0.f; + segrb0[1] = -1e3f; + segrb0[2] = 0.f; + segrb0[3] = 1e3f; + nsegrb0 = 2; + ksegrb0[0] = -1; + ksegrb0[1] = -1; + +/* Search for left-shifted notes, Make up the initial right-barrier, which */ +/* will be good for all permutations. */ +/* irest()(27) is set if any notes are left-shifted */ +/* Must use ALL chord notes, not just ones w/ accid's. */ + + if (bit_test(*irest,27)) { + i__1 = comtrill_1.icrd2; + for (icrd = comtrill_1.icrd1 - 1; icrd <= i__1; ++icrd) { + if (icrd == comtrill_1.icrd1 - 1) { + +/* Main note */ + +/* lshift = btest(ipl,8) */ + lshift = bit_test(*ipl,8) || bit_test(*nacc,31); + if (lshift) { + nolev = *nolevm; + } + } else { + +/* Chord note */ + + lshift = bit_test(comtrill_1.icrdat[icrd - 1],23); +/* if (lshift) nolev = igetbits(icrdat(icrd),7,12) */ + if (lshift) { + nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, & + c__12); + if (bit_test(*nacc,31) && nolev == *nolevm + 1) { + +/* This note is not really shifted, It is the upper of a 2nd with the main */ +/* note on an upstem, and Main note must be shifted. */ +/* nacc(31) signals the real truth. */ + + lshift = FALSE_; + } + } + } + if (lshift) { + i__2 = nsegrb0 - 1; + for (isegrb = 1; isegrb <= i__2; ++isegrb) { + if (segrb0[(isegrb + 1 << 1) - 1] > (real) (nolev - 1)) { + +/* Add this notehead to the right boundary here. Move all higher segs up 2. */ + + i__3 = isegrb + 1; + for (iiseg = nsegrb0; iiseg >= i__3; --iiseg) { + segrb0[(iiseg + 2 << 1) - 2] = segrb0[(iiseg << 1) + - 2]; + segrb0[(iiseg + 2 << 1) - 1] = segrb0[(iiseg << 1) + - 1]; + ksegrb0[iiseg + 1] = ksegrb0[iiseg - 1]; +/* L17: */ + } + goto L18; + } +/* L16: */ + } +L18: + +/* Insert notehead into list. Set kseg=-2 to signal notehead shift. */ + + iiseg = isegrb + 1; + segrb0[(iiseg << 1) - 2] = -1.2f; + segrb0[(iiseg << 1) - 1] = nolev - 1.f; + ksegrb0[iiseg - 1] = -2; + segrb0[(iiseg + 1 << 1) - 2] = 0.f; + segrb0[(iiseg + 1 << 1) - 1] = nolev + 1.f; + ksegrb0[iiseg] = -1; + nsegrb0 += 2; + } +/* L15: */ + } + } + +/* Done setting right barrier for left-shifted noteheads */ + + tagged = FALSE_; + manual = FALSE_; + +/* Preprocess to check for manual shifts. */ +/* If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then */ +/* If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then */ +/* 1. Auto-shifting proceeds */ +/* 2. "A"-shifts add to autoshifts */ +/* 3. non-"A" shifts are ignored! */ +/* Else (>0 man shifts, none has "A") */ +/* No auto-ordering, No autoshifts, Observe all manual shifts. */ +/* End if */ +/* End if */ + + maxmanshft = 0; + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kicrd[i__] == 0) { + +/* Main note */ + + manshft = igetbits_(nacc, &c__7, &c__10); + if (manshft != 0) { + manual = TRUE_; + if (bit_test(*nacc,29)) { + tagged = TRUE_; + } else { +/* maxmanshft = max(maxmanshft,64-manshft) */ +/* Computing MAX */ + i__2 = maxmanshft, i__3 = 107 - manshft; + maxmanshft = max(i__2,i__3); + } + } + } else { + +/* Chord note */ + + manshft = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, & + c__20); + if (manshft != 0) { + manual = TRUE_; + if (bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) { + tagged = TRUE_; + } else { +/* maxmanshft = max(maxmanshft,64-manshft) */ +/* Computing MAX */ + i__2 = maxmanshft, i__3 = 107 - manshft; + maxmanshft = max(i__2,i__3); + } + } + } +/* L13: */ + } + if (manual) { + if (tagged) { + +/* zero out all untagged shifts */ + + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kicrd[i__] == 0) { + if (! bit_test(*nacc,29)) { + setbits_(nacc, &c__7, &c__10, &c__0); + } + } else { + if (! bit_test(comtrill_1.icrdat[kicrd[i__] - 1],29)) { + setbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__7, & + c__20, &c__0); + } + } +/* L14: */ + } + } else { + +/* There are manual shifts but none tagged. Only proceed if "Ao" was entered */ + + if (! bit_test(*nacc,28)) { + *icashft = maxmanshft; + return 0; + } + } + } + if (bit_test(*nacc,28)) { + +/* Take the accidentals in order as originally input, then exit. */ + + crdacc_(nacc, naccid, &kicrd[1], nolevm, &rmsshift, &c_true, &idummy, + &idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); + return 0; +/* end if */ + } else if (*naccid == 3) { + +/* Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd */ +/* then place in order top, bottom, middle. */ + + for (i__ = 1; i__ <= 3; ++i__) { + if (kicrd[i__] == 0) { + irank = *icrdot0; + nolev = *nolevm; + } else { + irank = igetbits_(&comtrill_1.icrdot[kicrd[i__] - 1], &c__3, & + c__27); + nolev = igetbits_(&comtrill_1.icrdat[kicrd[i__] - 1], &c__7, & + c__12); + } + if (irank == 1) { + micrd[0] = kicrd[i__]; + } else { + micrd[5 - irank - 1] = kicrd[i__]; + } + if (irank == 2) { + levmidacc = nolev; + } +/* L20: */ + } + if (*levmaxacc != levmidacc + 1 && levmidacc != *levminacc + 1) { + crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy, + &idummy, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); + return 0; + } + } + rmsmin = 1e5f; + +/* Initialize permutation array */ + + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + iperm[i__ - 1] = i__; +/* L7: */ + } + +/* Start looping over permutations */ + + for (ip = 1; ip <= 5041; ++ip) { + if (ip != 1) { + +/* Work the magic algorithm to get the next permutation */ + + for (k = *naccid - 1; k >= 1; --k) { + if (iperm[k - 1] <= iperm[k]) { + goto L2; + } +/* L1: */ + } + +/* If here, we just got the last permutation, so exit the loop over permutations */ + + goto L10; +L2: + for (j = *naccid; j >= 1; --j) { + if (iperm[k - 1] <= iperm[j - 1]) { + goto L4; + } +/* L3: */ + } +L4: + it = iperm[j - 1]; + iperm[j - 1] = iperm[k - 1]; + iperm[k - 1] = it; + is = k + 1; + for (ir = *naccid; ir >= 1; --ir) { + if (ir <= is) { + goto L6; + } + it = iperm[ir - 1]; + iperm[ir - 1] = iperm[is - 1]; + iperm[is - 1] = it; + ++is; +/* L5: */ + } +L6: + ; + } + +/* New we have a permutation. Take icrd values out of kicrd and put them into */ +/* micrd in the order of the permutation */ + + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + micrd[i__ - 1] = kicrd[iperm[i__ - 1]]; +/* L9: */ + } +/* c */ +/* c Temporary printout */ +/* c */ +/* write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) */ +/* c */ + crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_false, levmaxacc, + icrdot0, segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); +/* c */ +/* c Temporary printout */ +/* c */ +/* write(15,*)'perm done, rmsshift:',rmsshift */ +/* c */ + if (rmsshift < rmsmin) { + +/* Save this permutation, reset minrms */ + + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + ipermsav[i__ - 1] = iperm[i__ - 1]; + rmsmin = rmsshift; +/* L11: */ + } + } +/* L8: */ + } + s_wsle(&io___298); + do_lio(&c__9, &c__1, "Should not BEEEEEE here!", (ftnlen)24); + e_wsle(); + stop1_(); +L10: + +/* Done looping, get info for the final choice */ + + i__1 = *naccid; + for (i__ = 1; i__ <= i__1; ++i__) { + micrd[i__ - 1] = kicrd[ipermsav[i__ - 1]]; +/* L12: */ + } +/* c */ +/* c Temporary printout */ +/* c */ +/* write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) */ +/* c */ + crdacc_(nacc, naccid, micrd, nolevm, &rmsshift, &c_true, &idummy, &idummy, + segrb0, ksegrb0, &nsegrb0, twooftwo, icashft); + return 0; +} /* crdaccs_ */ + +/* Subroutine */ int doacc_(integer *ihshft, integer *ivshft, char *notexq, + integer *lnote, integer *nacc, integer *nolev, integer *ncm, logical * + caut, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[2], a__2[3]; + integer i__1[2], i__2[3]; + char ch__1[1]; + icilist ici__1; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) + ; + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + static char sq[1]; + static integer lacc; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static real hshft; + static char noteq[8]; + extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen); + static integer noleva; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static char acsymq[3]; + static integer lnoten; + + chax_(ch__1, (ftnlen)1, &c__92); + *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; + if (*ihshft == -107) { + *ihshft = 0; + } +/* c */ +/* c If main note shifted left, so shift accid. Terminate below, when acc. is done. */ +/* c */ + if (*ihshft != 0) { + +/* Accid must be shifted horizontally */ + + if (*ihshft < 0) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = sq; + i__1[1] = 8, a__1[1] = "loffset{"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + *ihshft = -(*ihshft); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = sq; + i__1[1] = 8, a__1[1] = "roffset{"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + } + hshft = *ihshft * .05f; + if (hshft < 1.f) { + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = 3; + ici__1.iciunit = notexq + 9; + ici__1.icifmt = "(f3.2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real)); + e_wsfi(); + *lnote = 12; + } else { + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = 4; + ici__1.iciunit = notexq + 9; + ici__1.icifmt = "(f4.2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&hshft, (ftnlen)sizeof(real)); + e_wsfi(); + *lnote = 13; + } +/* Writing concatenation */ + i__2[0] = *lnote, a__2[0] = notexq; + i__2[1] = 2, a__2[1] = "}{"; + i__2[2] = 1, a__2[2] = sq; + s_cat(notexq, a__2, i__2, &c__3, (ftnlen)79); + *lnote += 3; + } else { + s_copy(notexq, sq, (ftnlen)79, (ftnlen)1); + *lnote = 1; + } + if (bit_test(*nacc,3)) { +/* Writing concatenation */ + i__1[0] = *lnote, a__1[0] = notexq; + i__1[1] = 3, a__1[1] = "big"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + *lnote += 3; + } + if (*caut) { + +/* Cautionary accidental. Need to define bigcna,... in pmx.tex */ + +/* Writing concatenation */ + i__1[0] = *lnote, a__1[0] = notexq; + i__1[1] = 1, a__1[1] = "c"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + ++(*lnote); + } + accsym_(nacc, acsymq, &lacc, (ftnlen)3); +/* Writing concatenation */ + i__1[0] = *lnote, a__1[0] = notexq; + i__1[1] = lacc, a__1[1] = acsymq; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + *lnote += lacc; + noleva = *nolev; + if (*ivshft != 0) { + noleva = noleva + *ivshft - 32; + } + notefq_(noteq, &lnoten, &noleva, ncm, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } +/* Writing concatenation */ + i__1[0] = *lnote, a__1[0] = notexq; + i__1[1] = lnoten, a__1[1] = noteq; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + *lnote += lnoten; + if (*ihshft != 0) { + +/* Terminate horizontal shift */ + +/* Writing concatenation */ + i__1[0] = *lnote, a__1[0] = notexq; + i__1[1] = 1, a__1[1] = "}"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + ++(*lnote); + } + return 0; +} /* doacc_ */ + +/* Subroutine */ int docrd_(integer *ivx, integer *ip, integer *nodu, integer + *ncm, integer *iv, real *tnow, char *soutq, integer *lsout, char *ulq, + integer *ibmcnt, integer *islur, integer *nvmx, integer *nv, logical + *beamon, integer *nolevm, integer *ihornb, integer *nornb, real * + stemlen, logical *dotxtup, integer *nacc, ftnlen soutq_len, ftnlen + ulq_len) +{ + /* System generated locals */ + address a__1[2]; + integer i__1, i__2, i__3[2], i__4, i__5, i__6; + logical L__1; + char ch__1[1]; + + /* Builtin functions */ + integer pow_ii(integer *, integer *), lbit_shift(integer, integer); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), + s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + extern integer igetbits_(integer *, integer *, integer *); + static integer kv; + extern integer log2_(integer *); + static integer icrd; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer lout, lsym; + static char outq[79]; + extern /* Subroutine */ int stop1_(void), doacc_(integer *, integer *, + char *, integer *, integer *, integer *, integer *, logical *, + ftnlen); + extern integer ncmid_(integer *, integer *); + static integer lnote, nolev; + static char noteq[8]; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen); + static integer nactmp; + static logical isleft; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static real updotc, rtdotc; + static integer lnoten, nolevo; + extern /* Subroutine */ int dotmov_(real *, real *, char *, integer *, + integer *, ftnlen), putarp_(real *, integer *, integer *, integer + *, integer *, char *, integer *, ftnlen); + static char notexq[79], nosymq[7]; + extern /* Subroutine */ int putorn_(integer *, integer *, integer *, + integer *, integer *, char *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, real *, char *, + integer *, integer *, integer *, logical *, logical *, ftnlen, + ftnlen), addmidi_(integer *, integer *, integer *, integer *, + real *, logical *, logical *); + static logical isright; + extern /* Subroutine */ int setbits_(integer *, integer *, integer *, + integer *); + + /* Fortran I/O blocks */ + static cilist io___323 = { 0, 6, 0, 0, 0 }; + static cilist io___324 = { 0, 6, 0, 0, 0 }; + + + + + +/* This subr. once produced notexq for entire chord. 10/18/97 altered to write */ +/* chord notes as we go. 10/22/97 find range of icrd first. */ +/* 2/25/98 moved rangefinding to precrd so done before slurs, so now */ +/* on entry, icrd1, icrd2 define range of icrd for this chord. */ + +/* Set counter (for this note) for chord notes present. Set notmain=T. */ +/* Will test for notmain=.true. in addmidi to tell whether to save pitch. */ + + /* Parameter adjustments */ + --nornb; + ihornb -= 25; + ulq -= 25; + + /* Function Body */ + commidi_1.nmidcrd = 0; + commidi_1.notmain = TRUE_; + commidi_1.crdacc = FALSE_; + i__1 = comtrill_1.icrd2; + for (icrd = comtrill_1.icrd1; icrd <= i__1; ++icrd) { + lnote = 0; + nolev = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12); + +/* 3/8/03 save original pitch to use in midi, in case 2nds alter things. */ + + nolevo = nolev; + +/* Check for special situations with 2nds (see precrd). */ + + if (bit_test(*nacc,30)) { + if (nolev == *nolevm - 1) { + nolev = *nolevm; + } + } else if (bit_test(*nacc,31)) { + if (nolev == *nolevm + 1) { + nolev = *nolevm; + } + } + +/* Lower dot for lower-voice notes?. Conditions are: */ +/* 1. Dotted time value */ +/* 2. Lower voice of two */ +/* 3. Note is on a line */ +/* 4. Not a rest (cannot be a rest in a chord!) */ +/* . 5. Flag (lowdot) is set to true */ + + if (comarp_1.lowdot && *nvmx == 2 && *ivx <= *nv) { + i__2 = log2_(nodu); + if (pow_ii(&c__2, &i__2) != *nodu && (nolev - *ncm) % 2 == 0) { + if (bit_test(comtrill_1.icrdat[icrd - 1],26)) { + +/* Note already in movdot list. Drop by 2. */ + + i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, & + c__0) - 20; + setbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__0, & + i__2); + } else { + +/* Not in list so just move it right now */ + + i__2 = igetbits_(islur, &c__1, &c__3); + dotmov_(&c_b735, &c_b736, soutq, lsout, &i__2, (ftnlen)80) + ; + } + } + } + if (bit_test(comtrill_1.icrdat[icrd - 1],26)) { + +/* Move the dot. */ + + updotc = ((127 & comtrill_1.icrdot[icrd - 1]) - 64) * .1f; + rtdotc = ((127 & lbit_shift(comtrill_1.icrdot[icrd - 1], (ftnlen) + -7)) - 64) * .1f; + i__2 = igetbits_(islur, &c__1, &c__3); + dotmov_(&updotc, &rtdotc, soutq, lsout, &i__2, (ftnlen)80); + } + isleft = bit_test(comtrill_1.icrdat[icrd - 1],23); + isright = bit_test(comtrill_1.icrdat[icrd - 1],24); + +/* Check for ornament in chord. */ + + if (comtrill_1.icrdorn[icrd - 1] > 0) { + putorn_(&comtrill_1.icrdorn[icrd - 1], &nolev, nolevm, nodu, & + nornb[1], ulq + 25, ibmcnt, ivx, ncm, islur, nvmx, nv, & + ihornb[25], stemlen, outq, &lout, ip, &c__0, beamon, & + c_true, (ftnlen)1, (ftnlen)79); + +/* subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, */ +/* * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, */ +/* * notcrd,beamon,iscrd) */ + + addstr_(outq, &lout, soutq, lsout, (ftnlen)79, (ftnlen)80); + } + +/* Chord-note symbol. First check for breve */ + + if (*nodu == 128) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "zbreve"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + lsym = 7; + } else { + +/* Not a breve chord. Get first letters in chord-note symbol */ + + if (isleft) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 1, a__1[1] = "l"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } else if (isright) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 1, a__1[1] = "r"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } else { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 1, a__1[1] = "z"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } + if (*nodu >= 64) { +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = nosymq; + i__3[1] = 1, a__1[1] = "w"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } else if (*nodu >= 32) { +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = nosymq; + i__3[1] = 1, a__1[1] = "h"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } else { +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = nosymq; + i__3[1] = 1, a__1[1] = "q"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + } + i__2 = log2_(nodu); + if (pow_ii(&c__2, &i__2) == *nodu && ! (*dotxtup)) { + lsym = 3; + } else if (! bit_test(*islur,3) || *dotxtup) { + +/* Single dot */ + +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = nosymq; + i__3[1] = 1, a__1[1] = "p"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + lsym = 4; + } else { + +/* Double dot */ + +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = nosymq; + i__3[1] = 2, a__1[1] = "pp"; + s_cat(nosymq, a__1, i__3, &c__2, (ftnlen)7); + lsym = 5; + } + } + if (bit_test(comtrill_1.icrdat[icrd - 1],19) && ! bit_test( + comtrill_1.icrdat[icrd - 1],27)) { + +/* Accidental and not MIDI-only. Build up bits 0-3 of nacc */ + + nactmp = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20); + +/* Kluge for bigness. Only means 'As' has not been issued */ + + if (spfacs_1.bacfac != 1e6f) { + nactmp += 8; + } + i__2 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__7, &c__20) - + 107; + i__4 = igetbits_(&comtrill_1.icrdot[icrd - 1], &c__6, &c__14); + i__5 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__7, &c__12); + i__6 = ncmid_(iv, ip); + L__1 = bit_test(comtrill_1.icrdat[icrd - 1],31); + doacc_(&i__2, &i__4, notexq, &lnote, &nactmp, &i__5, &i__6, &L__1, + (ftnlen)79); +/* * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) */ +/* Get original nolev, not altered to deal with 2nds */ +/* * ncmid(iv,ip)) */ +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 7, a__1[1] = nosymq; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + commidi_1.crdacc = TRUE_; + } else { + s_copy(notexq, nosymq, (ftnlen)79, (ftnlen)7); + } + lnote += lsym; + +/* Get note name (again if accid, due to possible octave jump) */ + + notefq_(noteq, &lnoten, &nolev, ncm, (ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + +/* Put in note name */ + +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 8, a__1[1] = noteq; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote += lnoten; + if (bit_test(comtrill_1.icrdat[icrd - 1],25)) { + +/* Arpeggio signal */ + +/* call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) */ + putarp_(tnow, ivx, ip, &nolev, ncm, soutq, lsout, (ftnlen)80); + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + if (commidi_1.ismidi) { + +/* Here is where we collect MIDI pitch info for the chord note. By checking */ +/* notmain, addmidi(...) knows to just compute the */ +/* pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() */ +/* for MAIN note, will put in note codes for all chord notes + main note. */ + + kv = 1; + if (*ivx > *iv) { + kv = 2; + } + ++commidi_1.nmidcrd; + if (commidi_1.nmidcrd > 20) { + s_wsle(&io___323); + e_wsle(); + s_wsle(&io___324); + do_lio(&c__9, &c__1, "21 chord notes is too many for midi pr" + "ocessor", (ftnlen)45); + e_wsle(); + stop1_(); + } + +/* Use original saved pitch level, unaltered by 2nds logic. */ + +/* call addmidi(midchan(iv,kv),nolevo, */ + i__2 = nolevo - cominsttrans_1.itransamt[cominsttrans_1.instno[* + iv - 1] - 1]; + i__4 = igetbits_(&comtrill_1.icrdat[icrd - 1], &c__3, &c__20); + addmidi_(&commidi_1.midchan[*iv + kv * 24 - 25], &i__2, &i__4, & + comtop_1.isig, &c_b781, &c_false, &c_false); + } +/* L5: */ + } + commidi_1.notmain = FALSE_; + return 0; +} /* docrd_ */ + +/* Subroutine */ int dodyn_(integer *ivx, integer *ip, integer *nolev, + integer *ncm, integer *ipl, integer *islur, integer *irest, integer * + nvmx, integer *nv, logical *beamon, integer *ihornb, integer *nornb, + char *ulq, integer *ibmcnt, logical *nostem, char *soutq, integer * + lsout, ftnlen ulq_len, ftnlen soutq_len) +{ + /* Initialized data */ + + static char dyntablq[48] = "ppppppp pp p mp mf f fp sfz ff fff " + "ffff"; + + /* System generated locals */ + address a__1[2], a__2[4], a__3[3], a__4[6]; + integer i__1, i__2, i__3[2], i__4[4], i__5, i__6[3], i__7[6]; + char ch__1[1], ch__2[6], ch__3[81], ch__4[53]; + icilist ici__1; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), + s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) + , s_wsfe(cilist *), e_wsfe(void); + + /* Local variables */ + extern /* Subroutine */ int backfill_(integer *, char *, integer *, char * + , integer *, ftnlen, ftnlen); + static integer jtxtdyn1; + extern integer igetbits_(integer *, integer *, integer *); + static integer lpretweak, id; + static real hoff; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer idno, lbot, idyn, jdyn; + extern /* Character */ VOID udqq_(char *, ftnlen, integer *, integer *, + integer *, integer *, integer *, integer *); + static integer lbot1; + extern integer lfmt1_(real *); + extern /* Subroutine */ int stop1_(void); + static integer idynd, lform, idynn[10], lnote, ltemp; + static char tempq[48]; + static integer ivxip; + static char numpq[5]; + static integer idynd2; + static real hoffsd; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen); + static integer iptent; + extern integer lenstr_(char *, integer *, ftnlen); + extern /* Subroutine */ int printl_(char *, ftnlen); + static integer numdyn; + static logical upstem; + static char notexq[79]; + static integer lnumpq, icntdyn, ivxtent; + static char dynstrq[4]; + static integer jtxtdyn, ltxtdyn; + + /* Fortran I/O blocks */ + static icilist io___345 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___347 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___348 = { 0, numpq+1, 0, "(i3)", 3, 1 }; + static icilist io___355 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___356 = { 0, numpq+1, 0, "(i2)", 2, 1 }; + static icilist io___357 = { 0, numpq+1, 0, "(i3)", 3, 1 }; + static cilist io___360 = { 0, 11, 0, "(a)", 0 }; + + + +/* Inputs are array *elements* except ihornb,nornb,ulq */ + + /* Parameter adjustments */ + ulq -= 25; + --nornb; + ihornb -= 25; + + /* Function Body */ + numdyn = 0; + +/* Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values */ +/* in idynn(1...4) */ + + i__1 = comdyn_1.ndyn; + for (idyn = 1; idyn <= i__1; ++idyn) { +/* ivxtent = iand(idyndat(idyn),15) */ + ivxtent = (comdyn_1.idyndat[idyn - 1] & 15) + (igetbits_(& + comdyn_1.idynda2[idyn - 1], &c__1, &c__10) << 4); + if (ivxtent == *ivx) { + iptent = igetbits_(&comdyn_1.idyndat[idyn - 1], &c__8, &c__4); + if (iptent == *ip) { + ++numdyn; + idynn[numdyn - 1] = idyn; + } else if (iptent > *ip) { + +/* I don't think there are any more possible for this ivx,ip, so exit loop */ + + goto L2; + } +/* else if (ivxtent .gt. ivx) then */ +/* go to 2 */ + } +/* L1: */ + } +L2: + +/* At this point there is a list of idyn's in idynn(1...numdyn) */ +/* Compute level, and stem-dir'n-based horizontal tweaks */ + + hoffsd = 0.f; + +/* Set upstem to false as default */ + + upstem = FALSE_; + if (bit_test(*irest,0)) { + +/* It's a rest. Assume it doesn't go below the staff */ + + lbot = *ncm - 4; + } else if (! (*beamon)) { + udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, nvmx, ivx, nv); + if (*(unsigned char *)&ch__1[0] == 'u' || *nostem) { + upstem = TRUE_; + if (! bit_test(*ipl,10)) { +/* Computing MIN */ + i__1 = *nolev - 1, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } else { +/* Computing MIN */ + i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } + } else { + hoffsd = -.5f; + if (! bit_test(*ipl,10)) { +/* Computing MIN */ + i__1 = *nolev - 7, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } else { +/* Computing MIN */ + i__1 = comtrill_1.minlev - 7, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } + } + } else { + if (*(unsigned char *)&ulq[*ivx + *ibmcnt * 24] == 'u') { + upstem = TRUE_; + if (! bit_test(*ipl,10)) { +/* Computing MIN */ + i__1 = *nolev - 1, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } else { +/* Computing MIN */ + i__1 = comtrill_1.minlev - 1, i__2 = *ncm - 4; + lbot = min(i__1,i__2); + } + } else { + hoffsd = -.5f; + lbot = ihornb[*ivx + nornb[*ivx] * 24] + 1; + if (lbot == 1) { + +/* Kluge for non-beamed, down xtup, for which ihorb was never set. */ +/* Assumes stem is shortened. */ + + lbot = *nolev - 5; + } + ++nornb[*ivx]; + } + } + lbot += -5; + jtxtdyn1 = 1; + +/* Now ready to loop over current dyn's */ + + i__1 = numdyn; + for (icntdyn = 1; icntdyn <= i__1; ++icntdyn) { + idynd = comdyn_1.idyndat[idynn[icntdyn - 1] - 1]; + idynd2 = comdyn_1.idynda2[idynn[icntdyn - 1] - 1]; + idno = igetbits_(&idynd, &c__4, &c__12); +/* ivx = iand(15,idynd) */ + *ivx = (15 & idynd) + (igetbits_(&idynd2, &c__1, &c__10) << 4); + +/* Build the command into notex in stages. Insert name & rq'd args in order: */ + +/* Command name */ +/* hpstrt, hpcend, hpdend, pmxdyn */ +/* ivx */ +/* X X X */ +/* level */ +/* X X X */ +/* hoff */ +/* X X X X */ +/* d-mark */ +/* X */ + + if (idno == 0) { + +/* Text-dynamic */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "txtdyn"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote = 7; + } else if (idno <= 12) { + +/* Letter-group */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "pmxdyn"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote = 7; + } else if (comslur_1.fontslur) { + lnote = 7; + if (idno == 13) { + +/* Start a hairpin */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "hpstrt"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + } else if (idno == 14) { + +/* End crescendo */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "hpcend"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + } else { + +/* End decrescendo */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "hpdend"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + } + } else { + +/* Postscript hairpins */ + + lnote = 7; + if (idno == 13) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "Icresc"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + } else if (idno == 14) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 8, a__1[1] = "Idecresc"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote = 9; + } else { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "Tcresc"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + } + } + if (idno >= 13) { + +/* Put in voice number */ + + if (*ivx <= 9) { +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + *(unsigned char *)&ch__1[0] = *ivx + 48; + i__3[1] = 1, a__1[1] = ch__1; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + ++lnote; + } else if (*ivx <= 19) { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{1"; + *(unsigned char *)&ch__1[0] = *ivx + 38; + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{2"; + *(unsigned char *)&ch__1[0] = *ivx + 28; + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } + } + +/* Begin setting level */ + + lbot1 = lbot; + if (idno > 0 && idno <= 5) { + +/* All letters are short so raise a bit. */ + + ++lbot1; + } else if (idno >= 13) { + lbot1 += 2; + } + +/* Convert so reference is bottom line */ + + lbot1 = lbot1 - *ncm + 4; + if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno + == 13 || idno == 14)) { + +/* Hairpin start. Save level and user-tweak before applying user tweak. */ + + comdyn_1.levdsav[*ivx - 1] = lbot1; + comdyn_1.levhssav[*ivx - 1] = 0; + if (bit_test(idynd,16)) { + comdyn_1.levhssav[*ivx - 1] = igetbits_(&idynd, &c__7, &c__17) + - 64; + } + } else if (comslur_1.fontslur && idno >= 14 || idno == 15) { + +/* Hairpin end; Compare level with saved start level before user-tweaks */ + +/* Computing MIN */ + i__2 = lbot1, i__5 = comdyn_1.levdsav[*ivx - 1]; + lbot1 = min(i__2,i__5); + +/* Save pre-tweak level */ + + lpretweak = lbot1; + } + +/* Check for user-defined vertical tweak */ + + if (bit_test(idynd,16)) { + lbot1 = lbot1 - 64 + igetbits_(&idynd, &c__7, &c__17); + } + +/* Now horizontal stuff */ + + hoff = hoffsd; + +/* Some special horizontal tweaks */ + + if (upstem && idno > 0 && (idno <= 4 || idno == 8 || idno == 9)) { + hoff += .4f; + } + +/* User-defined tweaks */ + + if (bit_test(idynd2,0)) { + hoff += (igetbits_(&idynd2, &c__9, &c__1) - 256) * .1f; + } + if (numdyn > 1) { + +/* Horizontal-interaction-based tweaks. */ + +/* Cases: */ +/* numdyn type1 type2 type3 data used */ +/* 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) */ +/* 2 hrpnend wrd-grp - ivowg,hoh2 */ +/* 2 hrpnend hrpnstrt - hoh2h1(1...2) */ +/* 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 */ + + if (idno > 0 && idno <= 12) { + +/* Word-group, may need vertical tweak to line up. */ + + lbot1 += comdyn_1.ivowg[idno - 1]; + +/* Protecting against hp start-stop on same note */ + + } else if ((comslur_1.fontslur && idno >= 14 || idno == 15) && + icntdyn < numdyn) { + +/* Hairpin ending, check next type */ + + if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[ + icntdyn] - 1], &c__4, &c__12) == 13 || ! + comslur_1.fontslur && (igetbits_(&comdyn_1.idyndat[ + idynn[icntdyn] - 1], &c__4, &c__12) == 13 || + igetbits_(&comdyn_1.idyndat[idynn[icntdyn] - 1], & + c__4, &c__12) == 14)) { + +/* Hairpin end then hairpin start, no words, (remember dealing with end now) */ + + hoff += comdyn_1.hoh2h1[0]; + } else { + +/* Hairpin end then word-group, need idno for w-g to set hp offset */ + + hoff += comdyn_1.hoh2[igetbits_(&comdyn_1.idyndat[idynn[ + icntdyn] - 1], &c__4, &c__12) - 1]; + } + +/* Protecting against hp start-stop on same note */ + + } else if (icntdyn > 1 && idno > 0 && (comslur_1.fontslur && idno + < 14 || ! comslur_1.fontslur && idno < 15)) { + +/* Hairpin start, check prior type */ + + if (comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[idynn[ + icntdyn - 2] - 1], &c__4, &c__12) >= 14 || ! + comslur_1.fontslur && igetbits_(&comdyn_1.idyndat[ + idynn[icntdyn - 2] - 1], &c__4, &c__12) == 15) { + +/* Hairpin end then hairpin start, (remember dealing with start now) */ + + hoff += comdyn_1.hoh2h1[1]; + } else { + +/* Hairpin start after word-group, need idno for w-g to set hp offset */ + + hoff += comdyn_1.hoh1[igetbits_(&comdyn_1.idyndat[idynn[ + icntdyn - 2] - 1], &c__4, &c__12) - 1]; + } + } + } + +/* End of if-block for 2- or 3-way interactions. */ + + if (! comslur_1.fontslur && idno >= 13) { + hoff = (hoff + .5f) * 6.f / 2.5f; + } + +/* Slur font and hairpin. Add hoff, and change from \interneote to \qn@width */ + + +/* Position corrections all done now. Put in the level. */ + + if (comslur_1.fontslur && idno == 13 || ! comslur_1.fontslur && (idno + == 13 || idno == 14)) { + +/* Hairpin start. */ + + if (! comslur_1.fontslur) { + +/* Postscript hairpin start...inset placeholder for start level. */ +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 5, a__1[1] = "{ }"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote += 5; + } + } else { + +/* Insert actual level in all cases except hairpin start */ +/* Create string with level in it */ + + if (lbot1 > 9) { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___345); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 4; + } else if (lbot1 > -1) { + *(unsigned char *)&ch__1[0] = lbot1 + 48; + s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1); + lnumpq = 1; + } else if (lbot1 > -10) { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___347); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 4; + } else { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___348); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 4, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 5; + } + +/* Level has now been computed and stored in numpq */ +/* Append the level */ + +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = lnumpq, a__1[1] = numpq; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + lnote += lnumpq; + } + if (dabs(hoff) < .001f) { + +/* No horiz offset */ + +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 1, a__1[1] = "0"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + ++lnote; + } else { + +/* Horizontal tweak */ + + lform = lfmt1_(&hoff); +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 1, a__1[1] = "{"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + ++lnote; + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + lform - i__2; + ici__1.iciunit = notexq + i__2; +/* Writing concatenation */ + i__6[0] = 2, a__3[0] = "(f"; + i__5 = lform + 48; + chax_(ch__1, (ftnlen)1, &i__5); + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 3, a__3[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__2, a__3, i__6, &c__3, (ftnlen)6), + ch__2); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&hoff, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += lform; +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(notexq, a__1, i__3, &c__2, (ftnlen)79); + ++lnote; + } + if (idno == 0) { + +/* text-dynamic. Find the string and append it */ + + i__2 = comdyn_1.ntxtdyn; + for (jtxtdyn = jtxtdyn1; jtxtdyn <= i__2; ++jtxtdyn) { +/* ivxip = ivx+16*ip */ + ivxip = *ivx + (*ip << 5); + if (ivxip == comdyn_1.ivxiptxt[jtxtdyn - 1]) { + goto L5; + } +/* L4: */ + } + printl_("Abnormal stop in putdyn", (ftnlen)23); + stop1_(); +L5: + ltxtdyn = lenstr_(comdyn_1.txtdynq + (jtxtdyn - 1 << 7), &c__128, + (ftnlen)128); + +/* Font size based on musicsize */ + + if (commus_1.musize == 20) { +/* Writing concatenation */ + i__7[0] = lnote, a__4[0] = notexq; + i__7[1] = 1, a__4[1] = "{"; + i__7[2] = 1, a__4[2] = "\\"; + i__7[3] = 7, a__4[3] = "medtype"; + i__7[4] = 1, a__4[4] = "\\"; + i__7[5] = 3, a__4[5] = "it "; + s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); + lnote += 13; + } else if (commus_1.musize == 16) { +/* Writing concatenation */ + i__7[0] = lnote, a__4[0] = notexq; + i__7[1] = 1, a__4[1] = "{"; + i__7[2] = 1, a__4[2] = "\\"; + i__7[3] = 8, a__4[3] = "normtype"; + i__7[4] = 1, a__4[4] = "\\"; + i__7[5] = 3, a__4[5] = "it "; + s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); + lnote += 14; + } else if (commus_1.musize == 24) { +/* Writing concatenation */ + i__7[0] = lnote, a__4[0] = notexq; + i__7[1] = 1, a__4[1] = "{"; + i__7[2] = 1, a__4[2] = "\\"; + i__7[3] = 7, a__4[3] = "bigtype"; + i__7[4] = 1, a__4[4] = "\\"; + i__7[5] = 3, a__4[5] = "it "; + s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); + lnote += 13; + } else if (commus_1.musize == 29) { +/* Writing concatenation */ + i__7[0] = lnote, a__4[0] = notexq; + i__7[1] = 1, a__4[1] = "{"; + i__7[2] = 1, a__4[2] = "\\"; + i__7[3] = 7, a__4[3] = "Bigtype"; + i__7[4] = 1, a__4[4] = "\\"; + i__7[5] = 3, a__4[5] = "it "; + s_cat(notexq, a__4, i__7, &c__6, (ftnlen)79); + lnote += 13; + } +/* Writing concatenation */ + i__6[0] = lnote, a__3[0] = notexq; + i__6[1] = ltxtdyn, a__3[1] = comdyn_1.txtdynq + (jtxtdyn - 1 << 7) + ; + i__6[2] = 1, a__3[2] = "}"; + s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79); + lnote = lnote + ltxtdyn + 1; + +/* Reset jtxtdyn1 just in case >1 txtdyn on same note. */ + + jtxtdyn1 = jtxtdyn + 1; + } else if (idno <= 12) { + +/* Letter-group dynamic. Append the letter-group command */ + + id = idno << 2; + i__2 = id - 4; + s_copy(dynstrq, dyntablq + i__2, (ftnlen)4, id - i__2); + id = lenstr_(dynstrq, &c__4, (ftnlen)4); +/* Writing concatenation */ + i__6[0] = lnote, a__3[0] = notexq; + chax_(ch__1, (ftnlen)1, &c__92); + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = id, a__3[2] = dynstrq; + s_cat(notexq, a__3, i__6, &c__3, (ftnlen)79); + lnote = lnote + 1 + id; + } + addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80); + if (! comslur_1.fontslur && idno == 15) { + +/* PS slurs on, hairpin is ending. Go back and set height at beginning. */ +/* Add user-defined tweak to default level */ + + lbot1 = lpretweak + comdyn_1.levhssav[*ivx - 1]; + if (lbot1 > 9) { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___355); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 4; + } else if (lbot1 > -1) { + *(unsigned char *)&ch__1[0] = lbot1 + 48; + s_copy(numpq, ch__1, (ftnlen)5, (ftnlen)1); + lnumpq = 1; + } else if (lbot1 > -10) { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___356); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 3, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 4; + } else { + s_copy(numpq, "{", (ftnlen)5, (ftnlen)1); + s_wsfi(&io___357); + do_fio(&c__1, (char *)&lbot1, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 4, a__1[0] = numpq; + i__3[1] = 1, a__1[1] = "}"; + s_cat(numpq, a__1, i__3, &c__2, (ftnlen)5); + lnumpq = 5; + } + +/* Construct string to search backwards for placeholder */ + + if (*ivx <= 9) { +/* Writing concatenation */ + i__6[0] = 5, a__3[0] = "cresc"; + *(unsigned char *)&ch__1[0] = *ivx + 48; + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 5, a__3[2] = "{ }"; + s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); + ltemp = 11; + } else if (*ivx <= 19) { +/* Writing concatenation */ + i__6[0] = 7, a__3[0] = "cresc{1"; + *(unsigned char *)&ch__1[0] = *ivx + 38; + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 6, a__3[2] = "}{ }"; + s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); + ltemp = 14; + } else { +/* Writing concatenation */ + i__6[0] = 7, a__3[0] = "cresc{2"; + *(unsigned char *)&ch__1[0] = *ivx + 28; + i__6[1] = 1, a__3[1] = ch__1; + i__6[2] = 6, a__3[2] = "}{ }"; + s_cat(tempq, a__3, i__6, &c__3, (ftnlen)48); + ltemp = 14; + } + s_wsfe(&io___360); +/* Writing concatenation */ + i__3[0] = *lsout, a__1[0] = soutq; + i__3[1] = 1, a__1[1] = "%"; + s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)81); + do_fio(&c__1, ch__3, *lsout + 1); + e_wsfe(); + *lsout = 0; +/* Writing concatenation */ + i__3[0] = ltemp - 5, a__1[0] = tempq; + i__3[1] = lnumpq, a__1[1] = numpq; + s_cat(ch__4, a__1, i__3, &c__2, (ftnlen)53); + i__2 = ltemp - 5 + lnumpq; + backfill_(&c__11, tempq, <emp, ch__4, &i__2, (ftnlen)48, ltemp + - 5 + lnumpq); + } +/* L3: */ + } + +/* Shrink arrays, decrease ndyn 111109 */ + + for (icntdyn = numdyn; icntdyn >= 1; --icntdyn) { + i__1 = comdyn_1.ndyn - 1; + for (jdyn = idynn[icntdyn - 1]; jdyn <= i__1; ++jdyn) { + comdyn_1.idyndat[jdyn - 1] = comdyn_1.idyndat[jdyn]; + comdyn_1.idynda2[jdyn - 1] = comdyn_1.idynda2[jdyn]; +/* L7: */ + } + --comdyn_1.ndyn; +/* L6: */ + } + return 0; +} /* dodyn_ */ + +/* Subroutine */ int dograce_(integer *ivx, integer *ip, real *ptgr, char * + soutq, integer *lsout, integer *ncm, integer *nacc, integer *ig, + integer *ipl, logical *farend, logical *beamon, integer *nolev, + integer *ncmidx, integer *islur, integer *nvmx, integer *nv, integer * + ibmcnt, real *tnote, char *ulq, ftnlen soutq_len, ftnlen ulq_len) +{ + /* System generated locals */ + address a__1[2], a__2[3], a__3[4]; + integer i__1, i__2[2], i__3[3], i__4[4], i__5, i__6; + real r__1; + char ch__1[1], ch__2[6], ch__3[2], ch__4[5], ch__5[11], ch__6[7], ch__7[4] + , ch__8[87], ch__9[15], ch__10[16], ch__11[9], ch__12[12], ch__13[ + 21], ch__14[20], ch__15[19], ch__16[24], ch__17[13], ch__18[82], + ch__19[3], ch__20[10]; + icilist ici__1; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen); + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer i_nint(real *), s_wsfi(icilist *), e_wsfi(void); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer i_sign(integer *, integer *); + + /* Local variables */ + extern /* Subroutine */ int addblank_(char *, integer *, ftnlen); + static integer lnotenga; + extern integer igetbits_(integer *, integer *, integer *); + static integer i__; + static real x, y, em; + static integer mg; + static char sq[1]; + static real finalshift; + static integer ing, ngs; + extern integer log2_(integer *); + static integer lacc; + static real beta; + extern /* Character */ VOID chax_(char *, ftnlen, integer *), udqq_(char * + , ftnlen, integer *, integer *, integer *, integer *, integer *, + integer *); + static real sumx, sumy; + extern /* Subroutine */ int stop1_(void); + static real delta, ptoff; + static integer lnote; + static char noteq[8]; + static real sumxx, sumxy, sumyy; + static integer nolev1; + static logical isgaft; + extern /* Subroutine */ int accsym_(integer *, char *, integer *, ftnlen), + addstr_(char *, integer *, char *, integer *, ftnlen, ftnlen); + static integer islope; + static logical iswaft; + static char acsymq[3]; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static integer lnoten, itrans, niptgr; + static logical stemup, normsp; + static char notexq[79], noteqga[8]; + static real wheadpt1; + + /* Fortran I/O blocks */ + static cilist io___366 = { 0, 6, 0, 0, 0 }; + static cilist io___370 = { 0, 6, 0, 0, 0 }; + static cilist io___371 = { 0, 6, 0, 0, 0 }; + static cilist io___372 = { 0, 15, 0, "(/,a)", 0 }; + static icilist io___375 = { 0, notexq, 0, "(i2)", 2, 1 }; + static cilist io___376 = { 0, 6, 0, 0, 0 }; + static icilist io___400 = { 0, notexq+13, 0, "(a1,f4.1)", 5, 1 }; + static icilist io___402 = { 0, notexq+13, 0, "(f4.1)", 4, 1 }; + static icilist io___404 = { 0, notexq+5, 0, "(f3.1)", 3, 1 }; + + + +/* ip will be one LESS than current note, for way-after's before bar-end, */ +/* It is only used to find ig. */ +/* ig is returned to makeabar in case there's a slur that needs to be ended */ + + /* Parameter adjustments */ + ulq -= 25; + --ptgr; + + /* Function Body */ + chax_(ch__1, (ftnlen)1, &c__92); + *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; + isgaft = bit_test(*ipl,29); + iswaft = bit_test(*ipl,31); + normsp = ! isgaft; + +/* Find ig. */ + + i__1 = comgrace_1.ngrace; + for (*ig = 1; *ig <= i__1; ++(*ig)) { + if (comgrace_1.ipg[*ig - 1] == *ip && comgrace_1.ivg[*ig - 1] == *ivx) + { + goto L121; + } +/* L120: */ + } + s_wsle(&io___366); + do_lio(&c__9, &c__1, "Problem finding grace index in dograce", (ftnlen)38) + ; + e_wsle(); + s_stop("", (ftnlen)0); +L121: + ngs = comgrace_1.ngstrt[*ig - 1]; + mg = comgrace_1.multg[*ig - 1]; + wheadpt1 = comask_1.wheadpt * comfig_1.fullsize[*ivx - 1]; + +/* For way-after-graces at end of bar, must set the octave. */ + + if (*farend) { + comoct_1.noctup = 0; + if (*ncm == 23) { + comoct_1.noctup = -2; + } + } + if (comgrace_1.slurg[*ig - 1] && ! iswaft && ! isgaft) { + if (comslur_1.listslur == 16777215) { + s_wsle(&io___370); + e_wsle(); + s_wsle(&io___371); + do_lio(&c__9, &c__1, "You defined the twentyfifth slur, one too " + "many!", (ftnlen)47); + e_wsle(); + s_wsfe(&io___372); + do_fio(&c__1, "You defined the twentyfifth slur, one too many!", ( + ftnlen)47); + e_wsfe(); + stop1_(); + } + +/* Slur on fore-grace. Get index of next slur not in use, from 23 down. */ + + i__1 = 16777215 - comslur_1.listslur; + comslur_1.ndxslur = log2_(&i__1); + } + if (comgrace_1.nng[*ig - 1] == 1) { + +/* Single grace. */ + + if (normsp) { + +/* Anything but GA */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 5, a__1[1] = "shlft"; + s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); + addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80); + niptgr = i_nint(&ptgr[*ig]); + +/* Empirical tweak for postscript. */ + +/* if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) */ +/* ++ */ + if (niptgr < 10) { +/* Writing concatenation */ + i__1 = niptgr + 48; + chax_(ch__1, (ftnlen)1, &i__1); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = 1, a__1[1] = "{"; + s_cat(ch__3, a__1, i__2, &c__2, (ftnlen)2); + addstr_(ch__3, &c__2, soutq, lsout, (ftnlen)2, (ftnlen)80); + } else if (niptgr < 100) { + s_wsfi(&io___375); + do_fio(&c__1, (char *)&niptgr, (ftnlen)sizeof(integer)); + e_wsfi(); +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = "{"; + i__3[1] = 2, a__2[1] = notexq; + i__3[2] = 2, a__2[2] = "}{"; + s_cat(ch__4, a__2, i__3, &c__3, (ftnlen)5); + addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80); + } else { + s_wsle(&io___376); + do_lio(&c__9, &c__1, "Call Dr. Don if you really want grace " + "note group > 99 pt", (ftnlen)56); + e_wsle(); + s_stop("", (ftnlen)0); + } + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 10, a__1[1] = "gaft{1.5}{"; + s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11); + addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80); + +/* GA. Compute aftshft, for later use. */ + + comgrace_1.aftshft = spfacs_1.grafac; + if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) { + comgrace_1.aftshft += spfacs_1.agc1fac; + } + comgrace_1.aftshft *= comask_1.wheadpt; + } + if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) { + +/* Start slur on pre-grace. No accounting needed since will be ended very soon. */ + + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) + 8); + if (comslur_1.fontslur) { + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 6, a__1[1] = "islurd"; + s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); + addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) + ; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 6, a__1[1] = "isluru"; + s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); + addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) + ; + } + } else { + +/* Start Postscript slur. */ + + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 3, a__1[1] = "isd"; + s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); + addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) + ; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 3, a__1[1] = "isu"; + s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); + addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) + ; + } + } + +/* Print slur number, 23-ndxslur */ + + lnote = 0; + if (23 - comslur_1.ndxslur < 10) { +/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ + i__1 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1); + lnote = 1; + } else if (23 - comslur_1.ndxslur < 20) { +/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ +/* Writing concatenation */ + i__3[0] = 2, a__2[0] = "{1"; + i__1 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__3[1] = 1, a__2[1] = ch__1; + i__3[2] = 1, a__2[2] = "}"; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + lnote = 4; + } else { +/* Writing concatenation */ + i__4[0] = lnote, a__3[0] = notexq; + i__4[1] = 2, a__3[1] = "{2"; + i__1 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[2] = 1, a__3[2] = ch__1; + i__4[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); + lnote = 4; + } +/* if (11-ndxslur .lt. 10) then */ +/* call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, */ +/* * soutq,lsout) */ +/* else */ +/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */ +/* * 4+lnoten,soutq,lsout) */ +/* end if */ +/* Writing concatenation */ + i__2[0] = lnote, a__1[0] = notexq; + i__2[1] = lnoten, a__1[1] = noteq; + s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87); + i__1 = lnote + lnoten; + addstr_(ch__8, &i__1, soutq, lsout, lnote + lnoten, (ftnlen)80); + if (! comslur_1.fontslur) { + +/* Horizontal tweaks for postscript slur on single grace */ + + stemup = TRUE_; + if (comgrace_1.upg[*ig - 1]) { + +/* Check for up-grace + down stem. Get stem direction */ + + if (! (*beamon)) { + +/* Separate note. Get stem direction. */ + + udqq_(ch__1, (ftnlen)1, nolev, ncmidx, islur, nvmx, + ivx, nv); + stemup = *(unsigned char *)&ch__1[0] == 'u'; + } else { + +/* In a beam */ + + stemup = *(unsigned char *)&ulq[*ivx + *ibmcnt * 24] + == 'u'; + } + +/* Stop the shift if whole note */ + + stemup = stemup || *tnote > 63.f; + } + if (stemup) { + addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen) + 80); + } else { + addstr_("{-.8}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen) + 80); + } + } + } + if (comgrace_1.naccg[ngs - 1] > 0) { + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) + 8); + +/* Save for checking octave shifts in GA */ + + if (isgaft) { + lnotenga = lnoten; + s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8); + } + + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3); +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 3, a__3[1] = "big"; + i__4[2] = lacc, a__3[2] = acsymq; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15); + i__1 = lacc + 4 + lnoten; + addstr_(ch__9, &i__1, soutq, lsout, lacc + 4 + lnoten, (ftnlen)80) + ; + } + if (comgrace_1.slashg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 3, a__1[1] = "grc"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + lnote = 4; + } else if (mg == 0) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 2, a__1[1] = "zq"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + lnote = 3; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 2, a__1[1] = "zc"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + i__1 = mg; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Writing concatenation */ + i__2[0] = i__ + 1, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "c"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); +/* L61: */ + } + lnote = mg + 2; + } + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "u"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__2[0] = lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "l"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + } + i__1 = lnote + 1; + addstr_(notexq, &i__1, soutq, lsout, (ftnlen)79, (ftnlen)80); + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8); + + if (isgaft && comgrace_1.naccg[ngs - 1] == 0) { + lnotenga = lnoten; + s_copy(noteqga, noteq, (ftnlen)8, (ftnlen)8); + } + + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + addstr_(noteq, &lnoten, soutq, lsout, (ftnlen)8, (ftnlen)80); + if (comgrace_1.slashg[*ig - 1]) { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 5, a__3[1] = "off{-"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 9, a__3[3] = "noteskip}"; + s_cat(ch__10, a__3, i__4, &c__4, (ftnlen)16); + addstr_(ch__10, &c__16, soutq, lsout, (ftnlen)16, (ftnlen)80); + } + +/* Above code needed since slashg causes spacing */ + + if (comgrace_1.slurg[*ig - 1] && (iswaft || isgaft)) { + +/* Terminate slur on single after-grace */ + +/* ndxslur = igetbits(ipl,4,23) */ + comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23); + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) + 8); +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 5, a__1[1] = "tslur"; + s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); + addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80); + +/* c Print 11-ndxslur */ +/* Print 24-ndxslur */ + +/* if (11-ndxslur .lt. 10) then */ + if (23 - comslur_1.ndxslur < 10) { +/* call addstr(chax(59-ndxslur)//noteq(1:lnoten), */ +/* Writing concatenation */ + i__1 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = lnoten, a__1[1] = noteq; + s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); + i__5 = lnoten + 1; + addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80); + } else if (23 - comslur_1.ndxslur < 20) { +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{2"; + i__1 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__5 = lnoten + 4; + addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); + } else { +/* call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), */ +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{1"; + i__1 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__5 = lnoten + 4; + addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); + } + comgrace_1.slurg[*ig - 1] = FALSE_; + comslur_1.listslur = bit_clear(comslur_1.listslur, + comslur_1.ndxslur); + } + addstr_("}", &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80); + +/* +++ Try to fix loss of octave with single gaft */ + +/* if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', */ +/* * 13+lnoten,soutq,lsout) */ + if (isgaft) { + itrans = 0; + i__1 = lnotenga; + for (i__ = 1; i__ <= i__1; ++i__) { + chax_(ch__1, (ftnlen)1, &c__39); + if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned char *)& + ch__1[0]) { + itrans += 7; + } else /* if(complicated condition) */ { + chax_(ch__1, (ftnlen)1, &c__96); + if (*(unsigned char *)¬eqga[i__ - 1] == *(unsigned + char *)&ch__1[0]) { + itrans += -7; + } + } +/* L1: */ + } + if (itrans == -14) { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 7, a__3[1] = "advance"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 12, a__3[3] = "transpose-14"; + s_cat(ch__13, a__3, i__4, &c__4, (ftnlen)21); + addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80); + } else if (itrans == -7) { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 7, a__3[1] = "advance"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 11, a__3[3] = "transpose-7"; + s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20); + addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80); + } else if (itrans == 7) { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 7, a__3[1] = "advance"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 10, a__3[3] = "transpose7"; + s_cat(ch__15, a__3, i__4, &c__4, (ftnlen)19); + addstr_(ch__15, &c__19, soutq, lsout, (ftnlen)19, (ftnlen)80); + } else if (itrans == 14) { +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 7, a__3[1] = "advance"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 11, a__3[3] = "transpose14"; + s_cat(ch__14, a__3, i__4, &c__4, (ftnlen)20); + addstr_(ch__14, &c__20, soutq, lsout, (ftnlen)20, (ftnlen)80); + } + } + } else { + +/* Multiple grace. Put in literally. Compute beam stuff */ + + sumx = 0.f; + sumy = 0.f; + sumxy = 0.f; + sumxx = 0.f; + sumyy = 0.f; + x = 0.f; + i__1 = ngs + comgrace_1.nng[*ig - 1] - 1; + for (ing = ngs; ing <= i__1; ++ing) { + if (ing > ngs && comgrace_1.naccg[ing - 1] > 0) { + x += spfacs_1.acgfac; + } + y = (real) comgrace_1.nolevg[ing - 1]; + sumx += x; + sumy += y; + sumxy += x * y; + sumxx += x * x; + sumyy += y * y; + x += spfacs_1.emgfac; +/* L118: */ + } + delta = comgrace_1.nng[*ig - 1] * sumxx - sumx * sumx; + em = (comgrace_1.nng[*ig - 1] * sumxy - sumx * sumy) / delta; + r__1 = em * .5f * spfacs_1.gslfac; + islope = i_nint(&r__1); + if (abs(islope) > 9) { + islope = i_sign(&c__9, &islope); + } + beta = (sumy - islope / spfacs_1.gslfac * sumx) / comgrace_1.nng[*ig + - 1]; + nolev1 = i_nint(&beta); + +/* Back up */ + +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 7, a__3[1] = "settiny"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 4, a__3[3] = "off{"; + s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); + if (normsp) { + s_wsfi(&io___400); + do_fio(&c__1, "-", (ftnlen)1); + do_fio(&c__1, (char *)&ptgr[*ig], (ftnlen)sizeof(real)); + e_wsfi(); +/* Writing concatenation */ + i__2[0] = 18, a__1[0] = notexq; + i__2[1] = 3, a__1[1] = "pt}"; + s_cat(ch__13, a__1, i__2, &c__2, (ftnlen)21); + addstr_(ch__13, &c__21, soutq, lsout, (ftnlen)21, (ftnlen)80); + finalshift = ptgr[*ig]; + } else { + comgrace_1.aftshft = comask_1.wheadpt * 1.33f; + if (comgrace_1.naccg[comgrace_1.ngstrt[*ig - 1] - 1] > 0) { + comgrace_1.aftshft += comask_1.wheadpt * .5f; + } + s_wsfi(&io___402); + do_fio(&c__1, (char *)&comgrace_1.aftshft, (ftnlen)sizeof(real)); + e_wsfi(); +/* Writing concatenation */ + i__4[0] = 17, a__3[0] = notexq; + i__4[1] = 3, a__3[1] = "pt}"; + i__4[2] = 1, a__3[2] = sq; + i__4[3] = 3, a__3[3] = "bsk"; + s_cat(ch__16, a__3, i__4, &c__4, (ftnlen)24); + addstr_(ch__16, &c__24, soutq, lsout, (ftnlen)24, (ftnlen)80); + } + +/* Start the beam */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 2, a__1[1] = "ib"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + i__1 = mg; + for (ing = 2; ing <= i__1; ++ing) { +/* Writing concatenation */ + i__2[0] = ing + 1, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "b"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); +/* L119: */ + } + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = mg + 2, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "u"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__2[0] = mg + 2, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "l"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + } +/* Writing concatenation */ + i__2[0] = mg + 3, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "0"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + +/* Get starting note for beam */ + + notefq_(noteq, &lnoten, &nolev1, ncm, (ftnlen)8); +/* Writing concatenation */ + i__2[0] = mg + 4, a__1[0] = notexq; + i__2[1] = lnoten, a__1[1] = noteq; + s_cat(ch__8, a__1, i__2, &c__2, (ftnlen)87); + i__1 = mg + 4 + lnoten; + addstr_(ch__8, &i__1, soutq, lsout, mg + 4 + lnoten, (ftnlen)80); + +/* Put in the slope */ + + if (islope >= 0) { + i__1 = islope + 48; + chax_(ch__1, (ftnlen)1, &i__1); + addstr_(ch__1, &c__1, soutq, lsout, (ftnlen)1, (ftnlen)80); + } else { +/* Writing concatenation */ + i__3[0] = 2, a__2[0] = "{-"; + i__1 = 48 - islope; + chax_(ch__1, (ftnlen)1, &i__1); + i__3[1] = 1, a__2[1] = ch__1; + i__3[2] = 1, a__2[2] = "}"; + s_cat(ch__7, a__2, i__3, &c__3, (ftnlen)4); + addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80); + } + +/* Start a slur on multiple fore-grace */ + + if (comgrace_1.slurg[*ig - 1] && ! isgaft && ! iswaft) { + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) + 8); + if (comslur_1.fontslur) { + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 6, a__1[1] = "islurd"; + s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); + addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) + ; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 6, a__1[1] = "isluru"; + s_cat(ch__6, a__1, i__2, &c__2, (ftnlen)7); + addstr_(ch__6, &c__7, soutq, lsout, (ftnlen)7, (ftnlen)80) + ; + } + } else { + +/* Need a tweak for postscript slur */ + + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 3, a__1[1] = "isd"; + s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); + addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) + ; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 3, a__1[1] = "isu"; + s_cat(ch__7, a__1, i__2, &c__2, (ftnlen)4); + addstr_(ch__7, &c__4, soutq, lsout, (ftnlen)4, (ftnlen)80) + ; + } + } + +/* Print 11-ndxslur */ + + if (23 - comslur_1.ndxslur < 10) { +/* Writing concatenation */ + i__1 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = lnoten, a__1[1] = noteq; + s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); + i__5 = lnoten + 1; + addstr_(ch__11, &i__5, soutq, lsout, lnoten + 1, (ftnlen)80); + } else if (23 - comslur_1.ndxslur < 2) { +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{1"; + i__1 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__5 = lnoten + 4; + addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); + } else { +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{1"; + i__1 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__1); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__5 = lnoten + 4; + addstr_(ch__12, &i__5, soutq, lsout, lnoten + 4, (ftnlen)80); + } + +/* Put in tweak for postscript slur */ + + if (! comslur_1.fontslur) { + addstr_("{-.3}", &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80); + } + } + +/* Put in first note. Call notefq again in case octave changed */ + + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen)8); + if (comgrace_1.naccg[ngs - 1] == 0) { +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = sq; + i__3[1] = 4, a__2[1] = "zqb0"; + i__3[2] = lnoten, a__2[2] = noteq; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + lnote = lnoten + 5; + } else { + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + accsym_(&comgrace_1.naccg[ngs - 1], acsymq, &lacc, (ftnlen)3); +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 3, a__3[1] = "big"; + i__4[2] = lacc, a__3[2] = acsymq; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); + lnote = lacc + 4 + lnoten; + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ngs - 1], ncm, (ftnlen) + 8); +/* Writing concatenation */ + i__4[0] = lnote, a__3[0] = notexq; + i__4[1] = 1, a__3[1] = sq; + i__4[2] = 4, a__3[2] = "zqb0"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(notexq, a__3, i__4, &c__4, (ftnlen)79); + lnote = lnote + 5 + lnoten; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + i__1 = ngs + comgrace_1.nng[*ig - 1] - 1; + for (ing = ngs + 1; ing <= i__1; ++ing) { + +/* Skip */ + + ptoff = wheadpt1 * spfacs_1.emgfac; + if (comgrace_1.naccg[ing - 1] > 0) { + ptoff += wheadpt1 * spfacs_1.acgfac; + } + if (isgaft && ! iswaft) { + comgrace_1.aftshft += ptoff; + } +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 4, a__1[1] = "off{"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + s_wsfi(&io___404); + do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); + e_wsfi(); + if (normsp) { + finalshift -= ptoff; + } +/* Writing concatenation */ + i__2[0] = 8, a__1[0] = notexq; + i__2[1] = 3, a__1[1] = "pt}"; + s_cat(ch__5, a__1, i__2, &c__2, (ftnlen)11); + addstr_(ch__5, &c__11, soutq, lsout, (ftnlen)11, (ftnlen)80); + if (ing == ngs + comgrace_1.nng[*ig - 1] - 1) { + +/* Terminate beam if needed */ + + if (comgrace_1.upg[*ig - 1]) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 4, a__1[1] = "tbu0"; + s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5); + addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80) + ; + } else { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 4, a__1[1] = "tbl0"; + s_cat(ch__4, a__1, i__2, &c__2, (ftnlen)5); + addstr_(ch__4, &c__5, soutq, lsout, (ftnlen)5, (ftnlen)80) + ; + } + +/* Terminate after slur if needed */ + + if ((isgaft || iswaft) && comgrace_1.slurg[*ig - 1]) { +/* if (iswaft) ndxslur = igetbits(ipl,4,23) */ + if (iswaft) { + comslur_1.ndxslur = igetbits_(ipl, &c__5, &c__23); + } + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, + (ftnlen)8); +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 5, a__1[1] = "tslur"; + s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)6); + addstr_(ch__2, &c__6, soutq, lsout, (ftnlen)6, (ftnlen)80) + ; + +/* Print 11-ndxslur */ +/* c Print 23-ndxslur */ + + if (23 - comslur_1.ndxslur < 10) { +/* Writing concatenation */ + i__5 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__5); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = lnoten, a__1[1] = noteq; + s_cat(ch__11, a__1, i__2, &c__2, (ftnlen)9); + i__6 = lnoten + 1; + addstr_(ch__11, &i__6, soutq, lsout, lnoten + 1, ( + ftnlen)80); + } else if (23 - comslur_1.ndxslur < 20) { +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{2"; + i__5 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__5); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__6 = lnoten + 4; + addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, ( + ftnlen)80); + } else { +/* Writing concatenation */ + i__4[0] = 2, a__3[0] = "{1"; + i__5 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__5); + i__4[1] = 1, a__3[1] = ch__1; + i__4[2] = 1, a__3[2] = "}"; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__12, a__3, i__4, &c__4, (ftnlen)12); + i__6 = lnoten + 4; + addstr_(ch__12, &i__6, soutq, lsout, lnoten + 4, ( + ftnlen)80); + } + +/* Stop slur terminator after exit from this subroutine */ + + comslur_1.listslur = bit_clear(comslur_1.listslur, + comslur_1.ndxslur); + comgrace_1.slurg[*ig - 1] = FALSE_; + } + } + +/* Accidental if needed */ + + if (comgrace_1.naccg[ing - 1] > 0) { + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, ( + ftnlen)8); + if (lnoten == 1) { + addblank_(noteq, &lnoten, (ftnlen)8); + } + accsym_(&comgrace_1.naccg[ing - 1], acsymq, &lacc, (ftnlen)3); +/* Writing concatenation */ + i__4[0] = 1, a__3[0] = sq; + i__4[1] = 3, a__3[1] = "big"; + i__4[2] = lacc, a__3[2] = acsymq; + i__4[3] = lnoten, a__3[3] = noteq; + s_cat(ch__9, a__3, i__4, &c__4, (ftnlen)15); + i__5 = lacc + 4 + lnoten; + addstr_(ch__9, &i__5, soutq, lsout, lacc + 4 + lnoten, ( + ftnlen)80); + } + +/* Put in the (beamed) grace note */ + + notefq_(noteq, &lnoten, &comgrace_1.nolevg[ing - 1], ncm, (ftnlen) + 8); +/* Writing concatenation */ + i__3[0] = 1, a__2[0] = sq; + i__3[1] = 4, a__2[1] = "zqb0"; + i__3[2] = lnoten, a__2[2] = noteq; + s_cat(ch__17, a__2, i__3, &c__3, (ftnlen)13); + i__5 = lnoten + 5; + addstr_(ch__17, &i__5, soutq, lsout, lnoten + 5, (ftnlen)80); +/* L127: */ + } + +/* Terminate the grace */ + +/* notexq = sq//'normalnotesize'//sq//'off{' */ +/* lnote = 20 */ +/* notexq = '}'//sq//'off{' */ +/* lnote = 6 */ +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 4, a__1[1] = "off{"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + lnote = 5; + ptoff = comask_1.wheadpt * spfacs_1.emgfac; + if ((*nacc & 3) > 0 && ! bit_test(*nacc,17)) { + ptoff += comask_1.wheadpt * spfacs_1.accfac; + } + if (isgaft && ! iswaft) { +/* Writing concatenation */ + i__2[0] = 5, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "-"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + lnote = 6; + ptoff = comgrace_1.aftshft; + } + if (normsp) { + ptoff = finalshift; + } + if (ptoff < 9.95f) { + i__1 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 3 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(f3.1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += 3; + } else if (ptoff < 99.95f) { + i__1 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 4 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(f4.1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += 4; + } else { + i__1 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 5 - i__1; + ici__1.iciunit = notexq + i__1; + ici__1.icifmt = "(f5.1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&ptoff, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += 5; + } +/* Writing concatenation */ + i__2[0] = lnote, a__1[0] = notexq; + i__2[1] = 3, a__1[1] = "pt}"; + s_cat(ch__18, a__1, i__2, &c__2, (ftnlen)82); + i__1 = lnote + 3; + addstr_(ch__18, &i__1, soutq, lsout, lnote + 3, (ftnlen)80); + if (isgaft && ! iswaft) { +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 2, a__1[1] = "sk"; + s_cat(ch__19, a__1, i__2, &c__2, (ftnlen)3); + addstr_(ch__19, &c__3, soutq, lsout, (ftnlen)3, (ftnlen)80); + } +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = sq; + i__2[1] = 9, a__1[1] = "resetsize"; + s_cat(ch__20, a__1, i__2, &c__2, (ftnlen)10); + addstr_(ch__20, &c__10, soutq, lsout, (ftnlen)10, (ftnlen)80); + } + return 0; +} /* dograce_ */ + +/* Subroutine */ int dopsslur_(integer *nolev, integer *isdat1, integer * + isdat2, integer *isdat3, integer *isdat4, integer *nsdat, integer *ip, + integer *iv, integer *kv, integer *nv, logical *beamon, integer *ncm, + char *soutq, integer *lsout, char *ulq, integer *islur, integer *ipl, + integer *iornq, integer *islhgt, real *tno, integer *nacc, ftnlen + soutq_len, ftnlen ulq_len) +{ + /* System generated locals */ + address a__1[3], a__2[4], a__3[2]; + integer i__1, i__2, i__3[3], i__4[4], i__5[2], i__6; + char ch__1[1], ch__2[1], ch__3[6], ch__4[9]; + icilist ici__1; + + /* Builtin functions */ + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + e_wsfe(void); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, + char **, integer *, integer *, ftnlen); + integer s_wsfi(icilist *), e_wsfi(void); + + /* Local variables */ + static integer ivoffinc; + extern integer igetbits_(integer *, integer *, integer *); + static integer j, icm; + extern integer log2_(integer *); + static integer imid; + extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char * + , ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *, + integer *, integer *, integer *, integer *, integer *); + extern integer lfmt1_(real *); + extern /* Subroutine */ int stop1_(void); + static integer ihoff; + static logical iscrd; + static integer isdat, ivoff; + static real shift; + static integer iupdn, lform, lnote; + static logical pstie; + static char noteq[8]; + static integer idcode, isdata; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen); + static logical settie; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static integer lnoten, nolevs; + static logical stemup; + static char notexq[79]; + extern /* Subroutine */ int setbits_(integer *, integer *, integer *, + integer *); + static integer numdrop; + static char slurudq[1]; + + /* Fortran I/O blocks */ + static cilist io___418 = { 0, 6, 0, 0, 0 }; + static cilist io___419 = { 0, 6, 0, 0, 0 }; + static cilist io___420 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___428 = { 0, 6, 0, 0, 0 }; + + + +/* Called once per main note. */ +/* 12 May 2002 Create this subroutine to isolate postscript slurs/ties. */ +/* Always set \Nosluradjust\Notieadjust */ + + +/* Bits in isdat1: */ +/* 13-17 iv */ +/* 3-10 ip */ +/* 11 start/stop switch */ +/* 12 kv-1 */ +/* 19-25 ichar(code$) */ +/* 26 force direction? */ +/* 27 forced dir'n = up if on, set in sslur; also */ +/* final direction, set in doslur when beam is started, used on term. */ +/* 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. */ +/* 18 int(ndxslur/16), ditto. So this allows ndxslur>15. */ + +/* Bits in isdat2 */ +/* 0 Chord switch. Not set on main note. */ +/* 1-2 left/right notehead shift. Set only for chord note. */ +/* 3 tie positioning */ +/* 4 dotted flag */ +/* 6-11 voff1 1-63 => -31...+31 */ +/* 12-18 hoff1 1-127 => -6.3...+6.3 */ +/* 19-25 nolev */ +/* 26 \sluradjust (p+s) */ +/* 27 \nosluradjust (p-s) */ +/* 28 \tieadjust (p+t) */ +/* 29 \notieadjust (p-t) */ + +/* Bits in isdat3: Only used for slur endings */ +/* 0 set if midslur (at least one argument) */ +/* 1 set if curve (2 more args) */ +/* 2-7 32+first arg (height correction) (1st arg may be negative) */ +/* 8-10 second arg (initial slope) */ +/* 11-13 third arg (closing slope) */ +/* 14-21 tie level for use in LineBreakTies */ +/* 22-29 ncm for use in LineBreakTies */ + +/* Bits in isdat4 Only used for linebreak slurs */ +/* 0-5 Linebreak seg 1 voff 1-63 => -31...+31 */ +/* 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 */ +/* 16-21 Linebreak seg 2 voff 1-63 => -31...+31 */ +/* 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 */ + +/* In listslur bit ib is on if slur index ib is in use, ib=0-13. */ +/* ndxslur = slur index */ +/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */ +/* s-slur is blank (idcode=32), t-slur is idcode=1. */ +/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */ +/* Ivoff will be set for ./_ only if no user-defined shift is specified. */ +/* If highest note has upslur, save slur height in islhgt in case */ +/* ornament must be moved. */ + + /* Parameter adjustments */ + --isdat4; + --isdat3; + --isdat2; + --isdat1; + + /* Function Body */ + *islhgt = 0; + if (*beamon) { + stemup = *(unsigned char *)ulq == 'u'; + } else if (commvl_1.nvmx[*iv - 1] == 2) { + if (! bit_test(*islur,30)) { + +/* Single note, 2 lines of music, stem direction not forced */ + + stemup = commvl_1.ivx > *nv; + } else { + stemup = bit_test(*islur,17); + } + } else { + udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], & + commvl_1.ivx, nv); + stemup = *(unsigned char *)&ch__1[0] == 'u'; + } + iscrd = bit_test(*ipl,10); + if (commidi_1.ismidi) { + settie = FALSE_; + comslm_1.dbltie = FALSE_; + } + i__1 = *nsdat; + for (isdat = 1; isdat <= i__1; ++isdat) { + isdata = isdat1[isdat]; + if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(& + isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, & + c__12) + 1) { + +/* Since iv and kv match, ivx will be correct */ + + idcode = igetbits_(&isdata, &c__7, &c__19); + ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32; + ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64; + iupdn = 0; + *(unsigned char *)slurudq = 'd'; + nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); + pstie = bit_test(isdat2[isdat],3) || idcode == 1; + if (bit_test(isdata,11)) { + +/* Turnon */ + +/* if (nolevs.eq.0 .or. nolevs.gt.60) then */ +/* c */ +/* c Note was a rest, cannot start slur on rest. */ +/* c */ +/* print* */ +/* call printl('Cannot start slur on a rest') */ +/* call stop1() */ +/* nolevs = ncm+5 */ +/* end if */ + +/* Get slur direction */ + + if (bit_test(isdata,26)) { + +/* Force slur direction */ + + if (bit_test(isdata,27)) { + *(unsigned char *)slurudq = 'u'; + } + } else if (commvl_1.nvmx[*iv - 1] == 1) { + +/* Only one voice per line */ + + if (! (*beamon)) { + +/* Separate note. */ + + udfq_(ch__1, (ftnlen)1, nolev, ncm); + *(unsigned char *)slurudq = *(unsigned char *)&ch__1[ + 0]; + } else { + +/* In a beam */ + + if (*(unsigned char *)ulq != 'u') { + *(unsigned char *)slurudq = 'u'; + } + } + if (iscrd) { + if (nolevs > *ncm) { + *(unsigned char *)slurudq = 'u'; + } else { + *(unsigned char *)slurudq = 'd'; + } + } + } else { + +/* Two voices per line. Get default */ + + if (commvl_1.ivx > *nv) { + *(unsigned char *)slurudq = 'u'; + } + +/* Upper voice of the two, so up slur */ + + } + +/* Set level for slur starting on rest */ + + if (nolevs == 0 || nolevs > 60) { + if (*(unsigned char *)slurudq == 'u') { + nolevs = *ncm + 2; + } else { + nolevs = *ncm - 2; + } + } + +/* Save up/down-ness for use at termination */ + + if (*(unsigned char *)slurudq == 'u') { + isdata = bit_set(isdata,27); + } + +/* End of section for setting slur direction, still in "Turnon" if-block. */ + + if (bit_test(*iornq,11) || bit_test(*iornq,12)) { + +/* Raise or lower slur by one unit provided . or _ is on same side as slur */ + + ivoffinc = 0; + if (stemup && *(unsigned char *)slurudq == 'd' || ! + stemup && *(unsigned char *)slurudq == 'u') { + +/* Must move the slur for _ or . */ + + if (stemup) { + ivoffinc = -1; + } else { + ivoffinc = 1; + } + if ((stemup && *nolev >= *ncm - 2 || ! stemup && * + nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, + abs(i__2)) % 2 == 0) { + ivoffinc <<= 1; + } + ivoff += ivoffinc; + } + } + if (comslur_1.listslur == 16777215) { + s_wsle(&io___418); + e_wsle(); + s_wsle(&io___419); + do_lio(&c__9, &c__1, "You1 defined the twentyfifth slur," + " one too many!", (ftnlen)48); + e_wsle(); + s_wsfe(&io___420); + do_fio(&c__1, "You defined the twentyfifth slur, one too" + " many!", (ftnlen)47); + e_wsfe(); + stop1_(); + } + +/* Get index of next slur not in use, starting from 12 down */ + + i__2 = 16777215 - comslur_1.listslur; + comslur_1.ndxslur = log2_(&i__2); +/* write(*,'()') */ +/* write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur */ + +/* Record slur index */ + + comslur_1.listslur = bit_set(comslur_1.listslur, + comslur_1.ndxslur); +/* write(*,'(10x,B24)')listslur */ + +/* Save for use on termination */ + +/* call setbits(isdata,4,28,ndxslur) */ +/* 080531 Allow >16 slurs */ + i__2 = comslur_1.ndxslur % 16; + setbits_(&isdata, &c__4, &c__28, &i__2); + i__2 = comslur_1.ndxslur / 16; + setbits_(&isdata, &c__1, &c__18, &i__2); + +/* Shift for stem? */ + + if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f) + { + if (! pstie) { + ihoff += 8; + } else { + ihoff += 2; + } + } + if (iscrd) { + +/* Additional horiz shifts for h-shifted noteheads? */ + + if (bit_test(isdat2[isdat],1)) { + +/* Slur start on left-shifted chord notehead. ASSUME downstem. */ + + if (nolevs == comtrill_1.minlev && *(unsigned char *) + slurudq == 'd') { + ihoff += -2; + } else { + ihoff += -10; + } + } else if (bit_test(isdat2[isdat],2)) { + +/* Right shifted chord notehead. ASSUME upstem. */ + + if (nolevs == comtrill_1.maxlev && *(unsigned char *) + slurudq == 'u') { + ihoff += 2; + } else { + ihoff += 10; + } + } + } + chax_(ch__1, (ftnlen)1, &c__92); + s_copy(notexq, ch__1, (ftnlen)79, (ftnlen)1); + lnote = 1; + +/* Check for local adjustment default changes */ + + if (bit_test(isdat2[isdat],26)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 10, a__1[1] = "sluradjust"; + chax_(ch__2, (ftnlen)1, &c__92); + i__3[2] = 1, a__1[2] = ch__2; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 12; + } else if (bit_test(isdat2[isdat],27)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 12, a__1[1] = "nosluradjust"; + chax_(ch__2, (ftnlen)1, &c__92); + i__3[2] = 1, a__1[2] = ch__2; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 14; + } else if (bit_test(isdat2[isdat],28)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 9, a__1[1] = "tieadjust"; + chax_(ch__2, (ftnlen)1, &c__92); + i__3[2] = 1, a__1[2] = ch__2; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 11; + } else if (bit_test(isdat2[isdat],29)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 11, a__1[1] = "notieadjust"; + chax_(ch__2, (ftnlen)1, &c__92); + i__3[2] = 1, a__1[2] = ch__2; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 13; + } + if (ihoff == 0) { + +/* Write stuff for non-shifted start */ + +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 5, a__1[1] = "islur"; + i__3[2] = 1, a__1[2] = slurudq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote += 6; + } else { +/* Writing concatenation */ + i__3[0] = lnote, a__1[0] = notexq; + i__3[1] = 2, a__1[1] = "is"; + i__3[2] = 1, a__1[2] = slurudq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote += 3; + } + +/* Prepend postscript tie switch */ + + if (pstie) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__4[0] = 1, a__2[0] = ch__1; + i__4[1] = 8, a__2[1] = "tieforis"; + i__4[2] = 1, a__2[2] = slurudq; + i__4[3] = lnote, a__2[3] = notexq; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 10; + } + if (bit_test(isdat2[isdat],4)) { + +/* Dotted slur */ + +/* noteq = notexq */ +/* notexq = chax(92)//'dotted'//noteq */ +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "dotted"; + i__3[2] = lnote, a__1[2] = notexq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote += 7; + } + +/* Add slur index to string */ +/* c Print 11-ndxslur */ +/* Print 23-ndxslur */ + +/* if (11-ndxslur .lt. 10) then */ + if (23 - comslur_1.ndxslur < 10) { + +/* 5/25/08 Allow 24 slurs */ + +/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__2 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__1; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + } else if (23 - comslur_1.ndxslur < 20) { +/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{1"; + i__2 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{2"; + i__2 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } + +/* Add note name to string */ + +/* call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) */ + *islhgt = nolevs + iupdn + ivoff; + notefq_(noteq, &lnoten, islhgt, ncm, (ftnlen)8); +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = lnoten, a__3[1] = noteq; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + lnote += lnoten; + +/* Store height and staff mid level for use with LineBreakTies */ + + setbits_(&isdat3[isdat], &c__8, &c__14, islhgt); + setbits_(&isdat3[isdat], &c__8, &c__22, ncm); + +/* Save height (for ornament and barnobox interference) if topmost slur is up */ + + if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ + isdat],0) || nolevs == comtrill_1.maxlev)) { + *islhgt = nolevs + iupdn + ivoff; + +/* Save height & idcode if top voice and slur start */ + + if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv + - 1] * 24 - 25] && *islhgt > comsln_1.is1n1) { + comsln_1.is1n1 = *islhgt; + comsln_1.is2n1 = idcode; + } + } + if ((real) ihoff != 0.f) { + shift = ihoff * .1f; +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 1, a__3[1] = "{"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + lform = lfmt1_(&shift); + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + lform - i__2; + ici__1.iciunit = notexq + i__2; +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = "(f"; + i__6 = lform + 48; + chax_(ch__1, (ftnlen)1, &i__6); + i__3[1] = 1, a__1[1] = ch__1; + i__3[2] = 3, a__1[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen) + 6), ch__3); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += lform; +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 1, a__3[1] = "}"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + +/* Zero out ip1 to avoid problems if slur goes to next input blk. */ + + setbits_(&isdata, &c__8, &c__3, &c__0); + +/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */ + + if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) { +/* levson(midchan(iv,kv)) = nolev */ + comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = + nolevs; + if (settie) { + comslm_1.dbltie = TRUE_; + } + +/* Only way settie=T is if we just set a tie ending. So there's also a slur */ +/* start here, so set a flag telling addmidi not to zero out levson */ + + } + } else { + +/* Slur is ending. Back thru list to find starting slur */ + + for (j = isdat - 1; j >= 1; --j) { + if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv == + igetbits_(&isdat1[j], &c__1, &c__12) + 1) { + if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) { + comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, & + c__28) + (igetbits_(&isdat1[j], &c__1, & + c__18) << 4); + +/* 080531 Allow >16 slurs */ + + if (bit_test(isdat1[j],27)) { + *(unsigned char *)slurudq = 'u'; + } + goto L4; + } + } +/* L3: */ + } + s_wsle(&io___428); + do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19); + e_wsle(); + stop1_(); +L4: + +/* Bugfix 070901 for slur ending on rest in 2-voice staff */ + +/* if (nolevs.eq.0 .or. nolevs.gt.60) then */ + if (nolevs <= 2 || nolevs > 60) { + +/* Ending is on a rest, reset nolevs to default starting height */ + + nolevs = igetbits_(&isdat2[j], &c__7, &c__19); + } + if (bit_test(isdat3[isdat],0) || bit_test(isdat3[j],0)) { + +/* Deal with \curve or \midslur. isdat is ending, j is start. */ + + if (bit_test(isdat3[isdat],0)) { + imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32; + } else { + imid = igetbits_(&isdat3[j], &c__6, &c__2) - 32; + } + +/* Postscript slurs, and \midslur adjustment is needed. Invoke macro */ +/* (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: */ +/* Abs(imid) Postscript slur type */ +/* 1 f */ +/* 2-3 default */ +/* 4 h */ +/* 5 H */ +/* 6+ HH */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 7, a__1[1] = "psforts"; +/* Computing MIN */ + i__6 = abs(imid); + i__2 = min(i__6,6) + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__3[2] = 1, a__1[2] = ch__2; + s_cat(ch__4, a__1, i__3, &c__3, (ftnlen)9); + addstr_(ch__4, &c__9, soutq, lsout, (ftnlen)9, (ftnlen)80) + ; + } + +/* Shift slur ending for stem on any note? */ + + if (! stemup && *(unsigned char *)slurudq == 'd' && *tno < + 63.f) { + if (! pstie) { + ihoff += -8; + } else { + ihoff += -3; + } + } + if (iscrd) { + +/* Shift termination for shifted notehead? */ + + if (bit_test(isdat2[isdat],1)) { + +/* Left-shifted chord notehead. ASSUME downstem. */ + + if (nolevs == comtrill_1.minlev && *(unsigned char *) + slurudq == 'd') { + ihoff += -2; + } else { + ihoff += -10; + } + } else if (bit_test(isdat2[isdat],2)) { + +/* Right shifted chord notehead. ASSUME upstem. */ + + if (nolevs == comtrill_1.maxlev && *(unsigned char *) + slurudq == 'u') { + ihoff += 2; + } else { + ihoff += 10; + } + } + } + if (ihoff == 0) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__5[0] = 1, a__3[0] = ch__1; + i__5[1] = 5, a__3[1] = "tslur"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + lnote = 6; + } else { + +/* Shift needed */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__5[0] = 1, a__3[0] = ch__1; + i__5[1] = 2, a__3[1] = "ts"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + lnote = 3; + } + +/* Switch to postscript tie */ + + if (pstie) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 8, a__1[1] = "tieforts"; + i__3[2] = lnote, a__1[2] = notexq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote += 9; + } + +/* Print 13-ndxslur */ +/* 5/25/08 Allow 14 slurs */ + + if (23 - comslur_1.ndxslur < 10) { +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__2 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__1; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + } else if (23 - comslur_1.ndxslur < 20) { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{1"; + i__2 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 2, a__2[1] = "{2"; + i__2 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[2] = 1, a__2[2] = ch__1; + i__4[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__4, &c__4, (ftnlen)79); + lnote += 4; + } + if (bit_test(*iornq,11) || bit_test(*iornq,12)) { + +/* Raise or lower slur by one unit provided . or _ is on same side as slur */ + + ivoffinc = 0; + if (stemup && *(unsigned char *)slurudq == 'd' || ! + stemup && *(unsigned char *)slurudq == 'u') { + if (stemup) { + ivoffinc = -1; + } else { + ivoffinc = 1; + } + if ((stemup && *nolev >= *ncm - 2 || ! stemup && * + nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, + abs(i__2)) % 2 == 0) { + ivoffinc <<= 1; + } + } + ivoff += ivoffinc; + } + i__2 = nolevs + iupdn + ivoff; + notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); + if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ + isdat],0) || nolevs == comtrill_1.maxlev)) { + *islhgt = nolevs + iupdn + ivoff; + +/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */ + + if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv + - 1] * 24 - 25] && comsln_1.is1n1 > 0) { + if (idcode == comsln_1.is2n1) { + comsln_1.is1n1 = 0; + } + } + } +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = lnoten, a__3[1] = noteq; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + lnote += lnoten; + if (ihoff != 0) { + shift = ihoff * .1f; +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 1, a__3[1] = "{"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + lform = lfmt1_(&shift); + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + lform - i__2; + ici__1.iciunit = notexq + i__2; +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = "(f"; + i__6 = lform + 48; + chax_(ch__1, (ftnlen)1, &i__6); + i__3[1] = 1, a__1[1] = ch__1; + i__3[2] = 3, a__1[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__3, a__1, i__3, &c__3, (ftnlen) + 6), ch__3); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += lform; +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 1, a__3[1] = "}"; + s_cat(notexq, a__3, i__5, &c__2, (ftnlen)79); + ++lnote; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + +/* Clear the bit from list of slurs in use */ + + comslur_1.listslur = bit_clear(comslur_1.listslur, + comslur_1.ndxslur); + +/* Zero out the entire strings for start and stop */ + + isdata = 0; + isdat2[isdat] = 0; + isdat3[isdat] = 0; + isdat4[isdat] = 0; + isdat1[j] = 0; + isdat2[j] = 0; + isdat3[j] = 0; + isdat4[j] = 0; + +/* Set midi info for slur ending */ + + if (commidi_1.ismidi && (idcode == 32 || idcode == 1)) { + icm = commidi_1.midchan[*iv + *kv * 24 - 25]; + if (comslm_1.slmon[icm]) { + if (nolevs == comslm_1.levson[icm] && (7 & *nacc) == + 0) { + +/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ + + comslm_1.levsoff[icm] = nolevs; + settie = TRUE_; + } else { + comslm_1.levsoff[icm] = 0; + comslm_1.levson[icm] = 0; + comslm_1.slmon[icm] = FALSE_; + } + } + } + } + isdat1[isdat] = isdata; + } +/* L1: */ + } + +/* Clear and collapse the slur data list */ + + numdrop = 0; + i__1 = *nsdat; + for (isdat = 1; isdat <= i__1; ++isdat) { + if (isdat1[isdat] == 0) { + ++numdrop; + } else if (numdrop > 0) { + isdat1[isdat - numdrop] = isdat1[isdat]; + isdat2[isdat - numdrop] = isdat2[isdat]; + isdat3[isdat - numdrop] = isdat3[isdat]; + isdat4[isdat - numdrop] = isdat4[isdat]; + isdat1[isdat] = 0; + isdat2[isdat] = 0; + isdat3[isdat] = 0; + isdat4[isdat] = 0; + } +/* L2: */ + } + *nsdat -= numdrop; +/* call report(nsdat,isdat1,isdat2) */ + return 0; +} /* dopsslur_ */ + +/* Subroutine */ int doslur_(integer *nolev, integer *isdat1, integer *isdat2, + integer *isdat3, integer *nsdat, integer *ip, integer *iv, integer * + kv, integer *nv, logical *beamon, integer *ncm, char *soutq, integer * + lsout, char *ulq, integer *islur, integer *ipl, integer *iornq, + integer *islhgt, real *tno, integer *nacc, ftnlen soutq_len, ftnlen + ulq_len) +{ + /* System generated locals */ + address a__1[3], a__2[2], a__3[4]; + integer i__1, i__2, i__3[3], i__4[2], i__5[4], i__6; + char ch__1[1], ch__2[6]; + icilist ici__1; + + /* Builtin functions */ + integer s_wsle(cilist *), e_wsle(void), do_lio(integer *, integer *, char + *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), + e_wsfe(void); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen), + s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsfi(icilist *), e_wsfi(void); + + /* Local variables */ + static integer ivoffinc; + extern integer igetbits_(integer *, integer *, integer *); + static integer j, icm; + extern integer log2_(integer *); + static integer imid; + extern /* Character */ VOID chax_(char *, ftnlen, integer *), udfq_(char * + , ftnlen, integer *, integer *), udqq_(char *, ftnlen, integer *, + integer *, integer *, integer *, integer *, integer *); + extern integer lfmt1_(real *); + extern /* Subroutine */ int stop1_(void); + static integer ihoff; + static logical iscrd; + static integer isdat, ivoff; + static real shift; + static integer iupdn, lform, lnote; + static char noteq[8]; + static logical tmove; + static integer idcode, isdata; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen); + static integer isdats; + static logical settie, sfound, tfound; + static integer isdatt; + extern /* Subroutine */ int notefq_(char *, integer *, integer *, integer + *, ftnlen); + static integer lnoten, nolevt, nolevs; + extern /* Subroutine */ int printl_(char *, ftnlen); + static logical stemup; + static char notexq[79]; + extern /* Subroutine */ int setbits_(integer *, integer *, integer *, + integer *); + static integer numdrop; + static char slurudq[1]; + + /* Fortran I/O blocks */ + static cilist io___449 = { 0, 6, 0, 0, 0 }; + static cilist io___451 = { 0, 6, 0, 0, 0 }; + static cilist io___452 = { 0, 6, 0, 0, 0 }; + static cilist io___453 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___461 = { 0, 6, 0, 0, 0 }; + + + +/* Called once per main note. (5/26/02) for non-ps slurs only */ + + +/* Bits in isdat1: */ +/* 13-17 iv */ +/* 3-10 ip */ +/* 11 start/stop switch */ +/* 12 kv-1 */ +/* 19-25 ichar(code$) */ +/* 26 force direction? */ +/* 27 forced dir'n = up if on, set in sslur; also */ +/* final direction, set in doslur when beam is started, used on term. */ +/* 28-31 ndxslur, set in doslur when beam is started, used on term. */ + +/* Bits in isdat2 */ +/* 0 Chord switch. Not set on main note. */ +/* 1-2 left/right notehead shift. Set only for chord note. */ +/* 3 tie positioning */ +/* 4 dotted flag */ +/* 6-11 voff1 1-63 => -31...+31 */ +/* 12-18 hoff1 1-127 => -6.3...+6.3 */ +/* 19-25 nolev */ + +/* Bits in isdat3: Only used for slur endings */ +/* 0 set if midslur (at least one argument) */ +/* 1 set if curve (2 more args) */ +/* 2-7 32+first arg (height correction) (1st arg may be negative) */ +/* 8-10 second arg (initial slope) */ +/* 11-13 third arg (closing slope) */ + +/* In listslur bit ib is on if slur index ib is in use, ib=0-23. */ +/* ndxslur = slur index */ +/* Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, */ +/* s-slur is blank (idcode=32), t-slur is idcode=1. */ +/* ivoff is user-defined shift or shift due to . or _ , or chord adjustment. */ +/* Ivoff will be set for ./_ only if no user-defined shift is specified. */ +/* If highest note has upslur, save slur height in islhgt in case */ +/* ornament must be moved. */ + + /* Parameter adjustments */ + --isdat3; + --isdat2; + --isdat1; + + /* Function Body */ + *islhgt = 0; + if (*beamon) { + stemup = *(unsigned char *)ulq == 'u'; + } else if (commvl_1.nvmx[*iv - 1] == 2) { + if (! bit_test(*islur,30)) { + +/* Single note, 2 lines of music, stem direction not forced */ + + stemup = commvl_1.ivx > *nv; + } else { + stemup = bit_test(*islur,17); + } + } else { + udqq_(ch__1, (ftnlen)1, nolev, ncm, islur, &commvl_1.nvmx[*iv - 1], & + commvl_1.ivx, nv); + stemup = *(unsigned char *)&ch__1[0] == 'u'; + } + iscrd = bit_test(*ipl,10); + if (bit_test(*islur,1)) { + +/* 't'-slur (idcode=1) somewhere on this note. Find it, check height against */ +/* 's'-slur (idcode=32) */ + + sfound = FALSE_; + tfound = FALSE_; + tmove = FALSE_; + i__1 = *nsdat; + for (isdat = 1; isdat <= i__1; ++isdat) { + if (*iv == igetbits_(&isdat1[isdat], &c__5, &c__13) && *ip == + igetbits_(&isdat1[isdat], &c__8, &c__3) && *kv == + igetbits_(&isdat1[isdat], &c__1, &c__12) + 1) { + if (! tfound) { + tfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 1; + if (tfound) { + nolevt = igetbits_(&isdat2[isdat], &c__7, &c__19); + isdatt = isdat; + if (sfound) { + goto L6; + } + } + } + if (! sfound) { + sfound = igetbits_(&isdat1[isdat], &c__7, &c__19) == 32; + if (sfound) { + nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); + isdats = isdat; + if (tfound) { + goto L6; + } + } + } + } +/* L5: */ + } + +/* Will come thru here if there is a t with no s, so comment out the following */ +/* print*,'Did not find s+t-slurs in doslur' */ + +L6: + if (sfound && tfound) { + tmove = nolevs == nolevt && (bit_test(isdat1[isdats],11) && + bit_test(isdat1[isdatt],11) || ! bit_test(isdat1[isdats], + 11) && ! bit_test(isdat1[isdatt],11)); + } + +/* Check if 2 starts or two stops */ + + +/* This is a flag for later changing slur level, after we know slur dir'n. */ + + } + if (commidi_1.ismidi) { + settie = FALSE_; + comslm_1.dbltie = FALSE_; + } + i__1 = *nsdat; + for (isdat = 1; isdat <= i__1; ++isdat) { + isdata = isdat1[isdat]; + if (*iv == igetbits_(&isdata, &c__5, &c__13) && *ip == igetbits_(& + isdata, &c__8, &c__3) && *kv == igetbits_(&isdata, &c__1, & + c__12) + 1) { + +/* Since iv and kv match, ivx will be correct */ + + idcode = igetbits_(&isdata, &c__7, &c__19); + ivoff = igetbits_(&isdat2[isdat], &c__6, &c__6) - 32; + ihoff = igetbits_(&isdat2[isdat], &c__7, &c__12) - 64; + iupdn = 0; + *(unsigned char *)slurudq = 'd'; + nolevs = igetbits_(&isdat2[isdat], &c__7, &c__19); + if (bit_test(isdata,11)) { + +/* Turnon, */ + + if (nolevs == 0 || nolevs > 60) { + +/* Note was a rest, cannot start slur on rest. */ + + s_wsle(&io___449); + e_wsle(); + printl_("Cannot start slur on a rest", (ftnlen)27); + stop1_(); + } + +/* Get slur direction */ + + if (bit_test(isdata,26)) { + +/* Force slur direction */ + + if (bit_test(isdata,27)) { + *(unsigned char *)slurudq = 'u'; + } + } else if (commvl_1.nvmx[*iv - 1] == 1) { + +/* Only one voice per line */ + + if (! (*beamon)) { + +/* Separate note. */ + + udfq_(ch__1, (ftnlen)1, nolev, ncm); + *(unsigned char *)slurudq = *(unsigned char *)&ch__1[ + 0]; + } else { + +/* In a beam */ + + if (*(unsigned char *)ulq != 'u') { + *(unsigned char *)slurudq = 'u'; + } + } + if (iscrd) { + if (nolevs > *ncm) { + *(unsigned char *)slurudq = 'u'; + } else { + *(unsigned char *)slurudq = 'd'; + } + } + } else { + +/* Two voices per line. Get default */ + + if (commvl_1.ivx > *nv) { + *(unsigned char *)slurudq = 'u'; + } + +/* Upper voice of the two, so up slur */ + + } + +/* Save up/down-ness for use at termination */ + + if (*(unsigned char *)slurudq == 'u') { + isdata = bit_set(isdata,27); + } + +/* End of section for setting slur direction, still in "Turnon" if-block. */ + + if (idcode == 1 && tmove) { + iupdn = 1; + if (*(unsigned char *)slurudq == 'd') { + iupdn = -1; + } + } + if (bit_test(*iornq,11) || bit_test(*iornq,12)) { + +/* Raise or lower slur by one unit provided . or _ is on same side as slur */ + + ivoffinc = 0; + if (stemup && *(unsigned char *)slurudq == 'd' || ! + stemup && *(unsigned char *)slurudq == 'u') { + +/* Must move the slur for _ or . */ + + if (stemup) { + ivoffinc = -1; + } else { + ivoffinc = 1; + } + if ((stemup && *nolev >= *ncm - 2 || ! stemup && * + nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, + abs(i__2)) % 2 == 0) { + ivoffinc <<= 1; + } + ivoff += ivoffinc; + } + } + if (comslur_1.listslur == 16777215) { + s_wsle(&io___451); + e_wsle(); + s_wsle(&io___452); + do_lio(&c__9, &c__1, "You1 defined the twenty-fifth slur" + ", one too many!", (ftnlen)49); + e_wsle(); + s_wsfe(&io___453); + do_fio(&c__1, "You2 defined the twenty-fifth slur, one t" + "oo many!", (ftnlen)49); + e_wsfe(); + stop1_(); + } + +/* Get index of next slur not in use, starting from ? down */ + + i__2 = 16777215 - comslur_1.listslur; + comslur_1.ndxslur = log2_(&i__2); + +/* Record slur index */ + + comslur_1.listslur = bit_set(comslur_1.listslur, + comslur_1.ndxslur); + +/* Save for use on termination */ + +/* call setbits(isdata,4,28,ndxslur) */ +/* 080531 Allow >16 slurs */ + i__2 = comslur_1.ndxslur % 16; + setbits_(&isdata, &c__4, &c__28, &i__2); + i__2 = comslur_1.ndxslur / 16; + setbits_(&isdata, &c__1, &c__18, &i__2); + +/* Shift for stem? */ + + if (stemup && *(unsigned char *)slurudq == 'u' && *tno < 63.f) + { + ihoff += 8; + } + if (bit_test(isdat2[isdat],3)) { + +/* Tie spacing, (slur start) */ + + if (*(unsigned char *)slurudq == 'd') { + ++ivoff; + ihoff += 8; + } else if (*(unsigned char *)slurudq == 'u') { + --ivoff; + if (! (stemup && *tno < 63.f)) { + ihoff += 8; + } + +/* (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') */ + + } + } + if (iscrd) { + +/* Additional horiz shifts for h-shifted noteheads? */ + + if (bit_test(isdat2[isdat],1)) { + +/* Slur start on left-shifted chord notehead. ASSUME downstem. */ + + if (nolevs == comtrill_1.minlev && *(unsigned char *) + slurudq == 'd') { + ihoff += -2; + } else { + ihoff += -10; + } + } else if (bit_test(isdat2[isdat],2)) { + +/* Right shifted chord notehead. ASSUME upstem. */ + + if (nolevs == comtrill_1.maxlev && *(unsigned char *) + slurudq == 'u') { + ihoff += 2; + } else { + ihoff += 10; + } + } + } + if (ihoff == 0) { + +/* Write stuff for non-shifted start */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 5, a__1[1] = "islur"; + i__3[2] = 1, a__1[2] = slurudq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 7; + } else { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 2, a__1[1] = "is"; + i__3[2] = 1, a__1[2] = slurudq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote = 4; + } + if (bit_test(isdat2[isdat],4)) { + +/* Dotted slur */ + + s_copy(noteq, notexq, (ftnlen)8, (ftnlen)79); +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__3[0] = 1, a__1[0] = ch__1; + i__3[1] = 6, a__1[1] = "dotted"; + i__3[2] = 8, a__1[2] = noteq; + s_cat(notexq, a__1, i__3, &c__3, (ftnlen)79); + lnote += 7; + } + +/* Add slur index to string */ +/* c Print 11-ndxslur */ +/* Print 23-ndxslur */ + +/* if (11-ndxslur .lt. 10) then */ + if (23 - comslur_1.ndxslur < 10) { + +/* 5/25/08 Allow 24 slurs */ + +/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__2 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[1] = 1, a__2[1] = ch__1; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + } else if (23 - comslur_1.ndxslur < 20) { +/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 2, a__3[1] = "{1"; + i__2 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[2] = 1, a__3[2] = ch__1; + i__5[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 2, a__3[1] = "{2"; + i__2 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[2] = 1, a__3[2] = ch__1; + i__5[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); + lnote += 4; + } + +/* Add note name to string */ + + i__2 = nolevs + iupdn + ivoff; + notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = lnoten, a__2[1] = noteq; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote += lnoten; + +/* Save height (for ornament and barnobox interference) if topmost slur is up */ + + if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ + isdat],0) || nolevs == comtrill_1.maxlev)) { + *islhgt = nolevs + iupdn + ivoff; + +/* Save height & idcode if top voice and slur start */ + + if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv + - 1] * 24 - 25] && *islhgt > comsln_1.is1n1) { + comsln_1.is1n1 = *islhgt; + comsln_1.is2n1 = idcode; + } + } + if ((real) ihoff != 0.f) { + shift = ihoff * .1f; +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "{"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + lform = lfmt1_(&shift); + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + lform - i__2; + ici__1.iciunit = notexq + i__2; +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = "(f"; + i__6 = lform + 48; + chax_(ch__1, (ftnlen)1, &i__6); + i__3[1] = 1, a__1[1] = ch__1; + i__3[2] = 3, a__1[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen) + 6), ch__2); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += lform; +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + +/* Zero out ip1 to avoid problems if slur goes to next input blk. */ + + setbits_(&isdata, &c__8, &c__3, &c__0); + +/* Set slur-on data for midi. Only treat null-index slurs and ps ties for now. */ + + if (commidi_1.ismidi && idcode == 32) { + comslm_1.levson[commidi_1.midchan[*iv + *kv * 24 - 25]] = + nolevs; + if (settie) { + comslm_1.dbltie = TRUE_; + } + +/* Only way settie=T is if we just set a tie ending. So there's also a slur */ +/* start here, so set a flag telling addmidi not to zero out levson */ + + } + } else { + +/* Slur is ending. Back thru list to find starting slur */ + + for (j = isdat - 1; j >= 1; --j) { + if (*iv == igetbits_(&isdat1[j], &c__5, &c__13) && *kv == + igetbits_(&isdat1[j], &c__1, &c__12) + 1) { + if (idcode == igetbits_(&isdat1[j], &c__7, &c__19)) { + comslur_1.ndxslur = igetbits_(&isdat1[j], &c__4, & + c__28) + (igetbits_(&isdat1[j], &c__1, & + c__18) << 4); + +/* 080531 Allow >16 slurs */ + + if (bit_test(isdat1[j],27)) { + *(unsigned char *)slurudq = 'u'; + } + goto L4; + } + } +/* L3: */ + } + s_wsle(&io___461); + do_lio(&c__9, &c__1, "Bad place in doslur", (ftnlen)19); + e_wsle(); + stop1_(); +L4: + if (nolevs == 0 || nolevs > 60) { + +/* Ending is on a rest, reset nolevs to default starting height */ + + nolevs = igetbits_(&isdat2[j], &c__7, &c__19); + } + if (bit_test(isdat3[isdat],0)) { + +/* Deal with \curve or \midslur */ + + imid = igetbits_(&isdat3[isdat], &c__6, &c__2) - 32; + +/* Remember, only dealing with non-ps slurs */ + +/* Who knows where the following line came from. Removed it 6/30/02 to */ +/* restore behavior of non-ps slurs to old way */ +/* if (slurudq .eq. 'd') imid = -imid */ +/* 3/8/03 added the following */ + + if (*(unsigned char *)slurudq == 'd') { + imid = -abs(imid); + } + + if (bit_test(isdat3[isdat],1)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__4[0] = 1, a__2[0] = ch__1; + i__4[1] = 5, a__2[1] = "curve"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote = 6; + } else { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__4[0] = 1, a__2[0] = ch__1; + i__4[1] = 7, a__2[1] = "midslur"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote = 8; + } + if (imid < 0 || imid > 9) { + +/* Need brackets */ + +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "{"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + if (imid < -9) { + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 3 - i__2; + ici__1.iciunit = notexq + i__2; + ici__1.icifmt = "(i3)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( + integer)); + e_wsfi(); + lnote += 3; + } else if (imid < 0 || imid > 9) { + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 2 - i__2; + ici__1.iciunit = notexq + i__2; + ici__1.icifmt = "(i2)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( + integer)); + e_wsfi(); + lnote += 2; + } else { + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + 1 - i__2; + ici__1.iciunit = notexq + i__2; + ici__1.icifmt = "(i1)"; + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&imid, (ftnlen)sizeof( + integer)); + e_wsfi(); + ++lnote; + } +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + } else { + +/* 1= 63.f) { + ihoff += -8; + } + } + } + if (iscrd) { + +/* Shift termination for shifted notehead? */ + + if (bit_test(isdat2[isdat],1)) { + +/* Left-shifted chord notehead. ASSUME downstem. */ + + if (nolevs == comtrill_1.minlev && *(unsigned char *) + slurudq == 'd') { + ihoff += -2; + } else { + ihoff += -10; + } + } else if (bit_test(isdat2[isdat],2)) { + +/* Right shifted chord notehead. ASSUME upstem. */ + + if (nolevs == comtrill_1.maxlev && *(unsigned char *) + slurudq == 'u') { + ihoff += 2; + } else { + ihoff += 10; + } + } + } + if (ihoff == 0) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__4[0] = 1, a__2[0] = ch__1; + i__4[1] = 5, a__2[1] = "tslur"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote = 6; + } else { + +/* Shift needed */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__4[0] = 1, a__2[0] = ch__1; + i__4[1] = 2, a__2[1] = "ts"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote = 3; + } + +/* Print 23-ndxslur */ +/* 5/25/08 Allow 14 slurs (???????????) */ + + if (23 - comslur_1.ndxslur < 10) { +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__2 = 71 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__4[1] = 1, a__2[1] = ch__1; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + } else if (23 - comslur_1.ndxslur < 20) { +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 2, a__3[1] = "{1"; + i__2 = 61 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[2] = 1, a__3[2] = ch__1; + i__5[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__5[0] = lnote, a__3[0] = notexq; + i__5[1] = 2, a__3[1] = "{2"; + i__2 = 51 - comslur_1.ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__5[2] = 1, a__3[2] = ch__1; + i__5[3] = 1, a__3[3] = "}"; + s_cat(notexq, a__3, i__5, &c__4, (ftnlen)79); + lnote += 4; + } + if (bit_test(*iornq,11) || bit_test(*iornq,12)) { + +/* Raise or lower slur by one unit provided . or _ is on same side as slur */ + + ivoffinc = 0; + if (stemup && *(unsigned char *)slurudq == 'd' || ! + stemup && *(unsigned char *)slurudq == 'u') { + if (stemup) { + ivoffinc = -1; + } else { + ivoffinc = 1; + } + if ((stemup && *nolev >= *ncm - 2 || ! stemup && * + nolev <= *ncm + 2) && (i__2 = *ncm - *nolev, + abs(i__2)) % 2 == 0) { + ivoffinc <<= 1; + } + } + ivoff += ivoffinc; + } + if (idcode == 1 && tmove) { + +/* t-slur height adjustment */ + + iupdn = 1; + if (*(unsigned char *)slurudq == 'd') { + iupdn = -1; + } + } + i__2 = nolevs + iupdn + ivoff; + notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); + if (*(unsigned char *)slurudq == 'u' && (! bit_test(isdat2[ + isdat],0) || nolevs == comtrill_1.maxlev)) { + *islhgt = nolevs + iupdn + ivoff; + +/* If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. */ + + if (commvl_1.ivx == commvl_1.ivmx[*nv + commvl_1.nvmx[*nv + - 1] * 24 - 25] && comsln_1.is1n1 > 0) { + if (idcode == comsln_1.is2n1) { + comsln_1.is1n1 = 0; + } + } + } +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = lnoten, a__2[1] = noteq; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + lnote += lnoten; + if (ihoff != 0) { + shift = ihoff * .1f; +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "{"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + lform = lfmt1_(&shift); + i__2 = lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = lnote + lform - i__2; + ici__1.iciunit = notexq + i__2; +/* Writing concatenation */ + i__3[0] = 2, a__1[0] = "(f"; + i__6 = lform + 48; + chax_(ch__1, (ftnlen)1, &i__6); + i__3[1] = 1, a__1[1] = ch__1; + i__3[2] = 3, a__1[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__2, a__1, i__3, &c__3, (ftnlen) + 6), ch__2); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&shift, (ftnlen)sizeof(real)); + e_wsfi(); + lnote += lform; +/* Writing concatenation */ + i__4[0] = lnote, a__2[0] = notexq; + i__4[1] = 1, a__2[1] = "}"; + s_cat(notexq, a__2, i__4, &c__2, (ftnlen)79); + ++lnote; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + +/* Clear the bit from list of slurs in use */ + + comslur_1.listslur = bit_clear(comslur_1.listslur, + comslur_1.ndxslur); + +/* Zero out the entire strings for start and stop */ + + isdata = 0; + isdat2[isdat] = 0; + isdat1[j] = 0; + isdat2[j] = 0; + isdat3[isdat] = 0; + +/* Set midi info for slur ending */ + + if (commidi_1.ismidi && idcode == 32) { + icm = commidi_1.midchan[*iv + *kv * 24 - 25]; + if (comslm_1.slmon[icm]) { + if (nolevs == comslm_1.levson[icm] && (7 & *nacc) == + 0) { + +/* There is a tie here. NB!!! assumed no accidental on 2nd member of tie. */ + + comslm_1.levsoff[icm] = nolevs; + settie = TRUE_; + } else { + comslm_1.levsoff[icm] = 0; + comslm_1.levson[icm] = 0; + comslm_1.slmon[icm] = FALSE_; + } + } + } + } + isdat1[isdat] = isdata; + } +/* L1: */ + } + +/* Clear and collapse the slur data list */ + + numdrop = 0; + i__1 = *nsdat; + for (isdat = 1; isdat <= i__1; ++isdat) { + if (isdat1[isdat] == 0) { + ++numdrop; + } else if (numdrop > 0) { + isdat1[isdat - numdrop] = isdat1[isdat]; + isdat2[isdat - numdrop] = isdat2[isdat]; + isdat3[isdat - numdrop] = isdat3[isdat]; + isdat1[isdat] = 0; + isdat2[isdat] = 0; + isdat3[isdat] = 0; + } +/* L2: */ + } + *nsdat -= numdrop; +/* call report(nsdat,isdat1,isdat2) */ + return 0; +} /* doslur_ */ + +/* Subroutine */ int dotmov_(real *updot, real *rtdot, char *soutq, integer * + lsout, integer *iddot, ftnlen soutq_len) +{ + /* System generated locals */ + address a__1[5], a__2[8], a__3[5]; + integer i__1[5], i__2, i__3, i__4[8], i__5[5], i__6; + char ch__1[1], ch__2[22], ch__3[1], ch__4[37], ch__5[15], ch__6[1]; + icilist ici__1; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) + ; + + /* Local variables */ + static char sq[1]; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + extern integer lfmt1_(real *); + static integer lnote; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen); + static integer lfmtup, lfmtrt; + static char notexq[80]; + + +/* iddot = 0 for single dot, 1 for double */ + + chax_(ch__1, (ftnlen)1, &c__92); + *(unsigned char *)sq = *(unsigned char *)&ch__1[0]; + lfmtup = lfmt1_(updot); + lfmtrt = lfmt1_(rtdot); + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = 80; + ici__1.iciunit = notexq; +/* Writing concatenation */ + i__1[0] = 6, a__1[0] = "(a37,f"; + i__2 = lfmtup + 48; + chax_(ch__1, (ftnlen)1, &i__2); + i__1[1] = 1, a__1[1] = ch__1; + i__1[2] = 7, a__1[2] = ".1,a2,f"; + i__3 = lfmtrt + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__1[3] = 1, a__1[3] = ch__3; + i__1[4] = 7, a__1[4] = ".1,a15)"; + ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__5, (ftnlen)22), ch__2); + s_wsfi(&ici__1); +/* Writing concatenation */ + i__4[0] = 1, a__2[0] = sq; + i__4[1] = 12, a__2[1] = "makeatletter"; + i__4[2] = 1, a__2[2] = sq; + i__4[3] = 3, a__2[3] = "def"; + i__4[4] = 1, a__2[4] = sq; + i__4[5] = 12, a__2[5] = "C@Point#1#2{"; + i__4[6] = 1, a__2[6] = sq; + i__4[7] = 6, a__2[7] = "PMXpt{"; + s_cat(ch__4, a__2, i__4, &c__8, (ftnlen)37); + do_fio(&c__1, ch__4, (ftnlen)37); + do_fio(&c__1, (char *)&(*updot), (ftnlen)sizeof(real)); + do_fio(&c__1, "}{", (ftnlen)2); + do_fio(&c__1, (char *)&(*rtdot), (ftnlen)sizeof(real)); +/* Writing concatenation */ + i__5[0] = 1, a__3[0] = "}"; + i__6 = *iddot + 48; + chax_(ch__6, (ftnlen)1, &i__6); + i__5[1] = 1, a__3[1] = ch__6; + i__5[2] = 1, a__3[2] = "}"; + i__5[3] = 1, a__3[3] = sq; + i__5[4] = 11, a__3[4] = "makeatother"; + s_cat(ch__5, a__3, i__5, &c__5, (ftnlen)15); + do_fio(&c__1, ch__5, (ftnlen)15); + e_wsfi(); + +/* Example of string just created: */ +/* \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\ */ + + lnote = lfmtup + 54 + lfmtrt; + addstr_(notexq, &lnote, soutq, lsout, lnote, (ftnlen)80); + return 0; +} /* dotmov_ */ + +/* Subroutine */ int dotrill_(integer *iv, integer *ip, integer *iornq, char * + noteq, integer *lnoten, char *notexq, integer *lnote, ftnlen + noteq_len, ftnlen notexq_len) +{ + /* System generated locals */ + address a__1[2], a__2[3]; + integer i__1, i__2[2], i__3[3], i__4; + char ch__1[1], ch__2[6]; + icilist ici__1; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen), s_cat(char *, char **, + integer *, integer *, ftnlen); + integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) + ; + + /* Local variables */ + static integer itr; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static integer nfmt; + static logical tronly; + + /* Fortran I/O blocks */ + static cilist io___471 = { 0, 6, 0, 0, 0 }; + + + i__1 = comtrill_1.ntrill; + for (itr = 1; itr <= i__1; ++itr) { + if (*iv == comtrill_1.ivtrill[itr - 1] && *ip == comtrill_1.iptrill[ + itr - 1]) { + goto L2; + } +/* L1: */ + } + s_wsle(&io___471); + do_lio(&c__9, &c__1, "Problem in dotrill. Call Dr. Don", (ftnlen)33); + e_wsle(); + s_stop("", (ftnlen)0); +L2: + tronly = comtrill_1.xnsktr[itr - 1] < .01f; + if (tronly) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = 9, a__1[1] = "zcharnote"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + *lnote = 10; + } else if (bit_test(*iornq,7)) { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = 6, a__1[1] = "Trille"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + *lnote = 7; + } else { +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__2[0] = 1, a__1[0] = ch__1; + i__2[1] = 6, a__1[1] = "trille"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + *lnote = 7; + } +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + i__3[1] = *lnoten, a__2[1] = noteq; + i__3[2] = 1, a__2[2] = "{"; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + *lnote = *lnote + *lnoten + 1; + +/* Write trill duration to nearest tenth of a noteskip */ + + if (tronly) { +/* Writing concatenation */ + i__3[0] = *lnote, a__2[0] = notexq; + chax_(ch__1, (ftnlen)1, &c__92); + i__3[1] = 1, a__2[1] = ch__1; + i__3[2] = 6, a__2[2] = "it tr}"; + s_cat(notexq, a__2, i__3, &c__3, (ftnlen)79); + *lnote += 7; + return 0; + } + if (comtrill_1.xnsktr[itr - 1] < .95f) { + nfmt = 2; + } else if (comtrill_1.xnsktr[itr - 1] < 9.95f) { + nfmt = 3; + } else { + nfmt = 4; + } + i__1 = *lnote; + ici__1.icierr = 0; + ici__1.icirnum = 1; + ici__1.icirlen = *lnote + nfmt - i__1; + ici__1.iciunit = notexq + i__1; +/* Writing concatenation */ + i__3[0] = 2, a__2[0] = "(f"; + i__4 = nfmt + 48; + chax_(ch__1, (ftnlen)1, &i__4); + i__3[1] = 1, a__2[1] = ch__1; + i__3[2] = 3, a__2[2] = ".1)"; + ici__1.icifmt = (s_cat(ch__2, a__2, i__3, &c__3, (ftnlen)6), ch__2); + s_wsfi(&ici__1); + do_fio(&c__1, (char *)&comtrill_1.xnsktr[itr - 1], (ftnlen)sizeof(real)); + e_wsfi(); + *lnote += nfmt; +/* Writing concatenation */ + i__2[0] = *lnote, a__1[0] = notexq; + i__2[1] = 1, a__1[1] = "}"; + s_cat(notexq, a__1, i__2, &c__2, (ftnlen)79); + ++(*lnote); + return 0; +} /* dotrill_ */ + +/* Subroutine */ int endslur_(logical *stemup, logical *upslur, integer * + nolev, integer *iupdn, integer *ndxslur, integer *ivoff, integer *ncm, + char *soutq, integer *lsout, logical *fontslur, ftnlen soutq_len) +{ + /* System generated locals */ + address a__1[2], a__2[4]; + integer i__1[2], i__2, i__3[4]; + char ch__1[1]; + + /* Builtin functions */ + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + + /* Local variables */ + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static logical shift; + static integer lnote; + static char noteq[8]; + extern /* Subroutine */ int addstr_(char *, integer *, char *, integer *, + ftnlen, ftnlen), notefq_(char *, integer *, integer *, integer *, + ftnlen); + static integer lnoten; + static char notexq[79]; + + +/* Only called to end slur started in dograce. */ + + shift = ! (*stemup) && ! (*upslur); + if (! shift) { + +/* No shift needed */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__1[0] = 1, a__1[0] = ch__1; + i__1[1] = 5, a__1[1] = "tslur"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + lnote = 6; + } else { + +/* Shift needed */ + +/* Writing concatenation */ + chax_(ch__1, (ftnlen)1, &c__92); + i__1[0] = 1, a__1[0] = ch__1; + i__1[1] = 2, a__1[1] = "ts"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + lnote = 3; + } +/* if (ndxslur .lt. 10) then */ +/* notexq = notexq(1:lnote)//chax(48+ndxslur) */ +/* lnote = lnote+1 */ +/* else */ +/* notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}' */ +/* lnote = lnote+4 */ +/* end if */ + +/* c Print 11-ndxslur */ +/* Print 23-ndxslur */ + +/* if (11-ndxslur .lt. 10) then */ + if (23 - *ndxslur < 10) { +/* notexq = notexq(1:lnote)//chax(59-ndxslur) */ +/* Writing concatenation */ + i__1[0] = lnote, a__1[0] = notexq; + i__2 = 71 - *ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__1[1] = 1, a__1[1] = ch__1; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + ++lnote; + } else if (23 - *ndxslur < 20) { +/* notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' */ +/* Writing concatenation */ + i__3[0] = lnote, a__2[0] = notexq; + i__3[1] = 2, a__2[1] = "{1"; + i__2 = 61 - *ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__3[2] = 1, a__2[2] = ch__1; + i__3[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79); + lnote += 4; + } else { +/* Writing concatenation */ + i__3[0] = lnote, a__2[0] = notexq; + i__3[1] = 2, a__2[1] = "{2"; + i__2 = 51 - *ndxslur; + chax_(ch__1, (ftnlen)1, &i__2); + i__3[2] = 1, a__2[2] = ch__1; + i__3[3] = 1, a__2[3] = "}"; + s_cat(notexq, a__2, i__3, &c__4, (ftnlen)79); + lnote += 4; + } + i__2 = *nolev + *iupdn + *ivoff; + notefq_(noteq, &lnoten, &i__2, ncm, (ftnlen)8); +/* Writing concatenation */ + i__1[0] = lnote, a__1[0] = notexq; + i__1[1] = lnoten, a__1[1] = noteq; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + lnote += lnoten; + if (shift) { + if (*fontslur) { +/* Writing concatenation */ + i__1[0] = lnote, a__1[0] = notexq; + i__1[1] = 5, a__1[1] = "{-.6}"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + } else { +/* Writing concatenation */ + i__1[0] = lnote, a__1[0] = notexq; + i__1[1] = 5, a__1[1] = "{-.8}"; + s_cat(notexq, a__1, i__1, &c__2, (ftnlen)79); + } + lnote += 5; + } + addstr_(notexq, &lnote, soutq, lsout, (ftnlen)79, (ftnlen)80); + return 0; +} /* endslur_ */ + +/* Subroutine */ int errmsg_(char *lineq, integer *iccount, integer *ibarno, + char *msgq, ftnlen lineq_len, ftnlen msgq_len) +{ + /* System generated locals */ + address a__1[2], a__2[5], a__3[4]; + integer i__1[2], i__2, i__3, i__4[5], i__5[4]; + real r__1; + char ch__1[18], ch__2[1], ch__3[1], ch__4[7], ch__5[79]; + cilist ci__1; + olist o__1; + cllist cl__1; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, + char **, integer *, integer *, ftnlen); + integer s_wsle(cilist *), e_wsle(void), f_open(olist *), s_wsfe(cilist *), + do_fio(integer *, char *, ftnlen), e_wsfe(void), f_clos(cllist *) + ; + double r_lg10(real *); + integer i_indx(char *, char *, ftnlen, ftnlen), do_lio(integer *, integer + *, char *, ftnlen); + + /* Local variables */ + static integer i1, i10; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static char outq[78]; + static integer iposn, ndigbn, ndignl, nlinep, lenmsg; + extern /* Subroutine */ int printl_(char *, ftnlen); + static integer ibarnop; + + /* Fortran I/O blocks */ + static cilist io___481 = { 0, 6, 0, 0, 0 }; + static cilist io___484 = { 0, 19, 0, "(i6)", 0 }; + static cilist io___488 = { 0, 6, 0, "(1x,a)", 0 }; + static cilist io___489 = { 0, 15, 0, "(a)", 0 }; + static cilist io___492 = { 0, 6, 0, 0, 0 }; + static cilist io___493 = { 0, 15, 0, "(a)", 0 }; + + + if (*iccount <= 78) { + s_copy(outq, lineq, (ftnlen)78, (ftnlen)78); + iposn = *iccount; + } else { +/* Writing concatenation */ + i__1[0] = 4, a__1[0] = "... "; + i__1[1] = 74, a__1[1] = lineq + 54; + s_cat(outq, a__1, i__1, &c__2, (ftnlen)78); + iposn = *iccount - 50; + } + s_wsle(&io___481); + e_wsle(); + ibarnop = *ibarno; + if (c1omget_1.linesinpmxmod == 0 || c1omget_1.nline > + c1omget_1.line1pmxmod + c1omget_1.linesinpmxmod) { + +/* Error is in main .pmx file */ + +/* nlinep = nline-linesinpmxmod */ +/* Correct for comments not copied into buffer */ + nlinep = truelinecount_1.linewcom[c1omget_1.nline - 1] - + c1omget_1.linesinpmxmod; + } else { + +/* Error is in include file */ + + ibarnop = 0; + nlinep = c1omget_1.nline - c1omget_1.line1pmxmod + 1; + printl_("ERROR in include file named above, description given below", + (ftnlen)58); + } + o__1.oerr = 0; + o__1.ounit = 19; + o__1.ofnmlen = 11; + o__1.ofnm = "pmxaerr.dat"; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1); + s_wsfe(&io___484); + do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); + e_wsfe(); + cl__1.cerr = 0; + cl__1.cunit = 19; + cl__1.csta = 0; + f_clos(&cl__1); +/* Computing MAX */ + r__1 = ibarnop + .1f; + i__2 = 1, i__3 = (integer) (r_lg10(&r__1) + 1); + ndigbn = max(i__2,i__3); + r__1 = nlinep + .1f; + ndignl = (integer) (r_lg10(&r__1) + 1); + lenmsg = i_indx(msgq, "!", msgq_len, (ftnlen)1) - 1; + +/* Split off msgq(..) since UNIX compilers don't allow concat substring!!! */ + + ci__1.cierr = 0; + ci__1.ciunit = 6; +/* Writing concatenation */ + i__4[0] = 8, a__2[0] = "(/,a15,i"; + i__2 = ndignl + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__4[1] = 1, a__2[1] = ch__2; + i__4[2] = 5, a__2[2] = ",a6,i"; + i__3 = ndigbn + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__4[3] = 1, a__2[3] = ch__3; + i__4[4] = 3, a__2[4] = ",$)"; + ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1); + s_wsfe(&ci__1); + do_fio(&c__1, " ERROR in line ", (ftnlen)15); + do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); + do_fio(&c__1, ", bar ", (ftnlen)6); + do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer)); + e_wsfe(); + s_wsfe(&io___488); + do_fio(&c__1, msgq, lenmsg); + e_wsfe(); + ci__1.cierr = 0; + ci__1.ciunit = 15; +/* Writing concatenation */ + i__4[0] = 8, a__2[0] = "(/,a15,i"; + i__2 = ndignl + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__4[1] = 1, a__2[1] = ch__2; + i__4[2] = 5, a__2[2] = ",a6,i"; + i__3 = ndigbn + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__4[3] = 1, a__2[3] = ch__3; + i__4[4] = 3, a__2[4] = ",$)"; + ci__1.cifmt = (s_cat(ch__1, a__2, i__4, &c__5, (ftnlen)18), ch__1); + s_wsfe(&ci__1); + do_fio(&c__1, " ERROR in line ", (ftnlen)15); + do_fio(&c__1, (char *)&nlinep, (ftnlen)sizeof(integer)); + do_fio(&c__1, ", bar ", (ftnlen)6); + do_fio(&c__1, (char *)&ibarnop, (ftnlen)sizeof(integer)); + e_wsfe(); + s_wsfe(&io___489); + do_fio(&c__1, msgq, lenmsg); + e_wsfe(); + i10 = iposn / 10; + i1 = iposn - i10 * 10; + ci__1.cierr = 0; + ci__1.ciunit = 6; +/* Writing concatenation */ + i__5[0] = 1, a__3[0] = "("; + i__2 = i10 + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__2; + i__3 = i1 + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__5[2] = 1, a__3[2] = ch__3; + i__5[3] = 4, a__3[3] = "x,a)"; + ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); + s_wsfe(&ci__1); + do_fio(&c__1, "v", (ftnlen)1); + e_wsfe(); + ci__1.cierr = 0; + ci__1.ciunit = 15; +/* Writing concatenation */ + i__5[0] = 1, a__3[0] = "("; + i__2 = i10 + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__2; + i__3 = i1 + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__5[2] = 1, a__3[2] = ch__3; + i__5[3] = 4, a__3[3] = "x,a)"; + ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); + s_wsfe(&ci__1); + do_fio(&c__1, "v", (ftnlen)1); + e_wsfe(); + s_wsle(&io___492); + do_lio(&c__9, &c__1, outq, (ftnlen)78); + e_wsle(); + s_wsfe(&io___493); +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = " "; + i__1[1] = 78, a__1[1] = outq; + s_cat(ch__5, a__1, i__1, &c__2, (ftnlen)79); + do_fio(&c__1, ch__5, (ftnlen)79); + e_wsfe(); + ci__1.cierr = 0; + ci__1.ciunit = 6; +/* Writing concatenation */ + i__5[0] = 1, a__3[0] = "("; + i__2 = i10 + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__2; + i__3 = i1 + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__5[2] = 1, a__3[2] = ch__3; + i__5[3] = 4, a__3[3] = "x,a)"; + ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); + s_wsfe(&ci__1); + do_fio(&c__1, "^", (ftnlen)1); + e_wsfe(); + ci__1.cierr = 0; + ci__1.ciunit = 15; +/* Writing concatenation */ + i__5[0] = 1, a__3[0] = "("; + i__2 = i10 + 48; + chax_(ch__2, (ftnlen)1, &i__2); + i__5[1] = 1, a__3[1] = ch__2; + i__3 = i1 + 48; + chax_(ch__3, (ftnlen)1, &i__3); + i__5[2] = 1, a__3[2] = ch__3; + i__5[3] = 4, a__3[3] = "x,a)"; + ci__1.cifmt = (s_cat(ch__4, a__3, i__5, &c__4, (ftnlen)7), ch__4); + s_wsfe(&ci__1); + do_fio(&c__1, "^", (ftnlen)1); + e_wsfe(); + return 0; +} /* errmsg_ */ + +/* Subroutine */ int eskb4_(integer *ip, integer *ivx, integer *in, integer * + ib, real *space, real *tstart, real *fbar, integer *itrpt, real *esk) +{ + /* System generated locals */ + real r__1; + + /* Builtin functions */ + integer i_nint(real *), s_wsle(cilist *), do_lio(integer *, integer *, + char *, ftnlen), e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen); + + /* Local variables */ + static integer iib; + extern doublereal feon_(real *); + static integer itnd, nnsk, itprev; + + /* Fortran I/O blocks */ + static cilist io___498 = { 0, 6, 0, 0, 0 }; + + + +/* Get elemskips to previous note. Called only for graces, no xtups involved. */ + + /* Parameter adjustments */ + --tstart; + --space; + + /* Function Body */ + itnd = i_nint(&all_1.to[*in - 1]); + if (*ip == 1 || itnd == *itrpt) { + +/* Start of bar or after rpt. */ + + *esk = *fbar; + return 0; + } else { + *esk = 0.f; + itprev = itnd - all_1.nodur[*ivx + (*ip - 1) * 24 - 25]; + for (iib = *ib; iib >= 1; --iib) { + if (tstart[iib] < itprev + comtol_1.tol) { + +/* This is the block */ + + r__1 = (real) (itnd - itprev) / space[iib]; + nnsk = i_nint(&r__1); + *esk += nnsk * feon_(&space[iib]); + return 0; + } else { + r__1 = (itnd - tstart[iib]) / space[iib]; + nnsk = i_nint(&r__1); + *esk += nnsk * feon_(&space[iib]); + itnd = i_nint(&tstart[iib]); + } +/* L1: */ + } + } + s_wsle(&io___498); + do_lio(&c__9, &c__1, "Problem in eskb4. Send files to Dr. Don", (ftnlen) + 40); + e_wsle(); + s_stop("", (ftnlen)0); + return 0; +} /* eskb4_ */ + +doublereal f1eon_(real *time) +{ + /* System generated locals */ + real ret_val; + + /* Builtin functions */ + double sqrt(doublereal); + + ret_val = sqrt(*time / 2); + return ret_val; +} /* f1eon_ */ + +doublereal feon_(real *time) +{ + /* System generated locals */ + real ret_val; + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal), pow_dd(doublereal *, doublereal *); + + d__1 = (doublereal) sqrt(*time / 2); + d__2 = (doublereal) (1.f - comeon_1.eonk); + ret_val = pow_dd(&d__1, &d__2) * comeon_1.ewmxk; + return ret_val; +} /* feon_ */ + +/* Subroutine */ int findbeam_(integer *ibmrep, integer *numbms, integer * + mapfb) +{ + /* Initialized data */ + + static integer nip1[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; + static integer nip2[248] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; + static integer nummask[3] = { 29,49,12 }; + static integer mask[147] /* was [49][3] */ = { 65535,4095,65520,255, + 65280,63,252,16128,64512,15,240,3840,61440,7,14,112,224,1792,3584, + 28672,57344,3,12,48,192,768,3072,12288,49152,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,16777215,65535,16776960,4095,65520,1048320, + 16773120,255,65280,16711680,63,252,16128,64512,4128768,16515072, + 15,60,240,3840,15360,61440,983040,3932160,15728640,7,14,112,224, + 1792,3584,28672,57344,458752,917504,7340032,14680064,3,12,48,192, + 768,3072,12288,49152,196608,786432,3145728,12582912,4095,255,4080, + 15,240,3840,3,12,48,192,768,3072,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 }; + static logical eqonly[147] /* was [49][3] */ = { TRUE_,TRUE_,TRUE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, + FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_ }; + + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + real r__1, r__2; + + /* Builtin functions */ + integer lbit_shift(integer, integer), s_wsle(cilist *), do_lio(integer *, + integer *, char *, ftnlen), e_wsle(void); + double r_mod(real *, real *); + + /* Local variables */ + static integer ib, ip, ir, it, is, ib1, ib2, ir1, is1, is2, it2, iip, ipr[ + 248], itr[248], mape, mapm, irep, maps, nreal, itend, itoff, + maskm, nodue[248], itseg, mtemp; + static logical short__[248]; + static integer itnow, ithalf, numnew; + extern /* Subroutine */ int logbeam_(integer *, integer *, integer *); + static integer masknow; + + /* Fortran I/O blocks */ + static cilist io___532 = { 0, 6, 0, 0, 0 }; + + + +/* Called once per voice per bar, after setting forced beams. */ + +/* integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16), */ +/* * itr(48),nodue(48) */ +/* logical short(48),eqonly */ + /* Parameter adjustments */ + --mapfb; + --numbms; + + /* Function Body */ + ip = 0; + nreal = 0; + itnow = 0; +L1: + ++ip; + if (ip > all_1.nn[commvl_1.ivx - 1]) { + goto L9; + } +L11: + if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] == 0) { + +/* Ignore all xtup notes except the last, the one with nodur > 0 . */ +/* Xtups are irrelevant here since they are already all in forced beams. */ +/* Will update itnow by nodur at the END of this loop */ + + ++ip; + goto L11; + } + ++nreal; + nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25]; + short__[nreal - 1] = nodue[nreal - 1] < 16 && ! bit_test(all_1.irest[ + commvl_1.ivx + ip * 24 - 25],0) && ! bit_test(all_1.islur[ + commvl_1.ivx + ip * 24 - 25],18); + +/* Rule out notes that have 'alone'-flag set */ + + ipr[nreal - 1] = ip; + itr[nreal - 1] = itnow; + if (nodue[nreal - 1] == 1) { + +/* 64th gap */ + + if (itnow % 2 == 0) { + +/* Start of 32nd gap, lump with following note */ + + ++ip; + nodue[nreal - 1] = all_1.nodur[commvl_1.ivx + ip * 24 - 25] + 1; + itnow += nodue[nreal - 1]; + } else { + +/* End of 32nd gap, lump with preceeding note */ + + --nreal; + ++nodue[nreal - 1]; + ++itnow; + } + } else { + itnow += all_1.nodur[commvl_1.ivx + ip * 24 - 25]; + } + goto L1; +L9: + ir1 = 1; + itseg = all_1.lenbar / *ibmrep; + i__1 = *ibmrep; + for (irep = 1; irep <= i__1; ++irep) { + +/* Set bitmaps for all shorts neighbored by a short. Each bit represents a */ +/* span of 32nd note. maps, mapm, mape record start, full duration, and end */ +/* of consecutive span of beamable (<1/4) notes. */ + + maps = 0; + mapm = 0; + mape = 0; + itend = itseg * irep; + itoff = itend - itseg; + i__2 = nreal; + for (ir = ir1; ir <= i__2; ++ir) { + it2 = itr[ir - 1] + nodue[ir - 1] - 2; + if (it2 >= itend) { + ir1 = ir; + goto L14; + } +/* if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal */ +/* Computing MAX */ + i__3 = ir - 1; + if (short__[ir - 1] && (ir > 1 && short__[max(i__3,1) - 1] || ir < + nreal && short__[ir])) { + ib1 = (itr[ir - 1] - itoff) / 2; + ib2 = (it2 - itoff) / 2; + if (max(ib1,ib2) > 47 || ir > 48 || min(ib1,ib2) < 0) { + return 0; + } + +/* Must have an odd number obe beats in a long bar. Auto-beam won't work */ + + nip1[ib1] = ipr[ir - 1]; + nip2[ib2] = ipr[ir - 1]; + +/* nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip */ + + maps = bit_set(maps,ib1); + mape = bit_set(mape,ib2); + i__3 = ib2; + for (ib = ib1; ib <= i__3; ++ib) { + mapm = bit_set(mapm,ib); +/* L3: */ + } + } +/* L2: */ + } +L14: + if (mapm == 0) { + goto L13; + } + +/* Zero out bits from forced beams */ + + maps &= ~ mapfb[irep]; + mapm &= ~ mapfb[irep]; + mape &= ~ mapfb[irep]; + +/* Compare map with template. */ + + i__2 = nummask[combeam_1.ibmtyp - 1]; + for (it = 1; it <= i__2; ++it) { + masknow = mask[it + combeam_1.ibmtyp * 49 - 50]; + if ((masknow & mapm) == masknow) { + +/* Find least significant bit in the mask to check start time */ + + mtemp = masknow; + maskm = masknow; + for (is1 = 0; is1 <= 47; ++is1) { + if ((1 & mtemp) == 1) { + goto L6; + } + mtemp = lbit_shift(mtemp, (ftnlen)-1); +/* L5: */ + } +L6: + if ((lbit_shift((ftnlen)1, is1) & maps) == 0) { + goto L4; + } + +/* is1 is the bit where the beam starts. Continue shifting to */ +/* find most significant bit in the mask to check ending time */ + + for (is2 = is1; is2 <= 47; ++is2) { + mtemp = lbit_shift(mtemp, (ftnlen)-1); + if ((1 & ~ mtemp) == 1) { + goto L8; + } +/* L7: */ + } +L8: + +/* is2 is now the bit on which the beam ends. */ + + if ((lbit_shift((ftnlen)1, is2) & mape) == 0) { + goto L4; + } + +/* Did we pick out a single note from the middle of a longer sequence? */ + + if (nip1[is1] == nip2[is2]) { + goto L4; + } + +/* We almost have a beam. Check equality of notes if needed. */ + + if (eqonly[it + combeam_1.ibmtyp * 49 - 50]) { + i__3 = nip2[is2]; + for (ip = nip1[is1]; ip <= i__3; ++ip) { + if (all_1.nodur[commvl_1.ivx + ip * 24 - 25] != 8) { + +/* There is a non-1/8th note in this beam. Exit if not 2 quarters */ + + if (is2 - is1 != 15) { + goto L4; + } + +/* Beam is 2 quarters long. Check if can split in half. */ + + ithalf = 0; + i__4 = nip2[is2]; + for (iip = nip1[is1]; iip <= i__4; ++iip) { + ithalf += all_1.nodur[commvl_1.ivx + iip * 24 + - 25]; + if (ithalf > 16) { + goto L4; + } + if (ithalf == 16) { + goto L21; + } +/* L20: */ + } + s_wsle(&io___532); + do_lio(&c__9, &c__1, "Problem in findbeam, pleas" + "e call Dr. Don", (ftnlen)40); + e_wsle(); + goto L4; +L21: + +/* Otherwise, split in half by keeping only the first half. Other half will */ +/* be picked up later, assuming masks are listed longest first. */ + + is2 = is1 + 7; + +/* Reset maskm (since only used part of mask), used later to zero out */ +/* bits that contain beams */ + + maskm = 0; + i__4 = is2; + for (is = is1; is <= i__4; ++is) { + maskm = bit_set(maskm,is); +/* L15: */ + } + goto L16; + } +/* L10: */ + } + } +L16: + +/* This is a beam. If last "effective" ends on odd 64th, add 1 more */ + +/* if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) */ +/* * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then */ + r__2 = all_1.to[comipl2_1.ipl2[commvl_1.ivx + nip2[is2] * 24 + - 25] - 1] + all_1.nodur[commvl_1.ivx + nip2[is2] * + 24 - 25] + comtol_1.tol * .5f; + if ((r__1 = r_mod(&r__2, &c_b1633), dabs(r__1)) > + comtol_1.tol) { + ++nip2[is2]; + } + ++numbms[commvl_1.ivx]; + numnew = numbms[commvl_1.ivx]; + logbeam_(&numnew, &nip1[is1], &nip2[is2]); + +/* Zero out the appropriate bits so these notes don't get used again */ + + mapm &= ~ maskm; + if (mapm == 0) { + goto L13; + } + maps &= ~ maskm; + mape &= ~ maskm; + } +L4: + ; + } +L13: + ; + } + return 0; +} /* findbeam_ */ + +/* Subroutine */ int findeonk_(integer *nptr1, integer *nptr2, real *wovera, + real *xelsk, real *dtmin, real *dtmax, real *eonk0) +{ + /* System generated locals */ + integer i__1; + real r__1; + doublereal d__1, d__2; + + /* Builtin functions */ + double pow_dd(doublereal *, doublereal *), sqrt(doublereal), log( + doublereal); + + /* Local variables */ + static real f, fp; + extern doublereal feon_(real *); + static real targ, esum; + static integer iptr; + extern doublereal f1eon_(real *); + static real desum, dsoln; + static integer niter; + static real detarg; + extern /* Subroutine */ int printl_(char *, ftnlen); + + +/* Compute an exponent eonk for use in the "flattened" formula for elemskips */ +/* vs time. We must solve the eqution f = 0. Initial quess is eonk0. */ + + comeon_1.eonk = *eonk0; + niter = 0; +L1: + d__1 = (doublereal) f1eon_(dtmax); + d__2 = (doublereal) comeon_1.eonk; + comeon_1.ewmxk = pow_dd(&d__1, &d__2); + ++niter; + esum = 0.f; + desum = 0.f; + i__1 = *nptr2; + for (iptr = *nptr1; iptr <= i__1; ++iptr) { + targ = c1omnotes_1.durb[iptr - 1] / c1omnotes_1.sqzb[iptr - 1]; + esum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] * + feon_(&targ); + d__1 = (doublereal) (*dtmax / targ); + d__2 = (doublereal) comeon_1.eonk; + detarg = sqrt(targ / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / targ); + desum += c1omnotes_1.nnpd[iptr - 1] * c1omnotes_1.sqzb[iptr - 1] * + detarg; +/* L2: */ + } + f = *wovera * feon_(dtmin) - *xelsk - esum; + d__1 = (doublereal) (*dtmax / *dtmin); + d__2 = (doublereal) comeon_1.eonk; + fp = *wovera * sqrt(*dtmin / 2 * pow_dd(&d__1, &d__2)) * log(*dtmax / * + dtmin) - desum; + if (dabs(fp) < comtol_1.tol || (r__1 = comeon_1.eonk - .5f, dabs(r__1)) > + .5f || niter > 100) { + printl_("Error in findeonk. Please send source to Dr. Don", (ftnlen) + 49); + comeon_1.eonk = 0.f; + comeon_1.ewmxk = 1.f; + return 0; + } + dsoln = -f / fp; + if (dabs(dsoln) < comtol_1.tol * .1f) { + return 0; + } + +/* Not converged yet, try again */ + + comeon_1.eonk += dsoln; + goto L1; +} /* findeonk_ */ + +doublereal fnote_(integer *nodur, integer *ivx, integer *ip, integer *nacc) +{ + /* System generated locals */ + real ret_val; + + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + + /* Local variables */ + static integer iip, ip1m1; + extern /* Subroutine */ int stop1_(void); + static integer ndoub, ipback; + extern /* Subroutine */ int printl_(char *, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___548 = { 0, 6, 0, 0, 0 }; + + + +/* This return the real duration of a note */ + + /* Parameter adjustments */ + nacc -= 25; + nodur -= 25; + + /* Function Body */ + ipback = *ip; + if (nodur[*ivx + *ip * 24] > 0) { + if (*ip > 1) { + +/* Check if this is last note of xtup */ + + if (nodur[*ivx + (*ip - 1) * 24] == 0) { + ipback = *ip - 1; + goto L2; + } + } + ret_val = (real) nodur[*ivx + *ip * 24]; + return ret_val; + } +L2: + +/* Count back to prior non zero note. Start at ip to avoid neg index if ip=1. */ +/* Count how many doubled xtups notes there are from ip-1 to first note. */ + + ndoub = 0; + for (ip1m1 = ipback; ip1m1 >= 1; --ip1m1) { + if (nodur[*ivx + ip1m1 * 24] > 0) { + goto L4; + } + if (ip1m1 < *ip && bit_test(nacc[*ivx + ip1m1 * 24],18)) { + ++ndoub; + } +/* L1: */ + } +L4: + +/* count forward to next non-0 nodur. Start at ip in case last note of xtup. */ + + for (iip = *ip; iip <= 200; ++iip) { + +/* Count doubled xtup notes from ip to end. */ + + if (bit_test(nacc[*ivx + iip * 24],18)) { + ++ndoub; + } + if (nodur[*ivx + iip * 24] > 0) { +/* fnote = nodur(ivx,iip)/float(iip-ip1m1) */ + ret_val = nodur[*ivx + iip * 24] / (real) (iip - ip1m1 + ndoub); + if (bit_test(nacc[*ivx + *ip * 24],18)) { + ret_val *= 2; + } else if (bit_test(nacc[*ivx + *ip * 24],27)) { + ret_val *= 1.5f; + } else if (*ip > 1) { + if (bit_test(nacc[*ivx + (*ip - 1) * 24],27)) { + ret_val *= .5f; + } + } + return ret_val; + } +/* L3: */ + } + s_wsle(&io___548); + do_lio(&c__9, &c__1, " ", (ftnlen)1); + e_wsle(); + printl_("Probable misplaced barline or incorrect meter, stopping", ( + ftnlen)55); +/* call printl('Program error in fnote, send source to Dr. Don') */ + stop1_(); + return ret_val; +} /* fnote_ */ + +/* Subroutine */ int g1etchar_(char *lineq, integer *iccount, char *charq, + ftnlen lineq_len, ftnlen charq_len) +{ + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer ndxm; + extern /* Subroutine */ int read10_(char *, logical *, ftnlen), m1rec1_( + char *, integer *, integer *, integer *, integer *, integer *, + ftnlen); + static integer nbars, ibaroff, ibarcnt; + + +/* Gets the next character out of lineq*128. If pointer iccount=128 on entry, */ +/* then reads in a new line. Resets iccount. Ends program if no more input. */ + + if (*iccount == 128) { + read10_(lineq, &c1omget_1.lastchar, (ftnlen)128); + if (c1omget_1.lastchar) { + return 0; + } + if (! commac_1.endmac) { + *iccount = 0; + if (! commac_1.mplay) { + ++c1omget_1.nline; + } + } else { + commac_1.endmac = FALSE_; + *iccount = commac_1.icchold; + s_copy(lineq, commac_1.lnholdq, (ftnlen)128, (ftnlen)128); + } + if (commac_1.mrecord) { + m1rec1_(lineq, iccount, &ibarcnt, &ibaroff, &nbars, &ndxm, ( + ftnlen)128); + } + } + ++(*iccount); + *(unsigned char *)charq = *(unsigned char *)&lineq[*iccount - 1]; + return 0; +} /* g1etchar_ */ + +/* Subroutine */ int g1etnote_(logical *loop, integer *ifig, logical * + optimize, logical *fulltrans) +{ + /* Initialized data */ + + static char literq[51*3] = "Literal TeX string cannot start with 4 backs" + "lashes!" "TeX string must have <129 char, end with backslash!" + "Type 2 or 3 TeX string can only start in column 1! "; + + /* System generated locals */ + address a__1[3], a__2[2], a__3[4]; + integer i__1, i__2[3], i__3[2], i__4, i__5, i__6, i__7, i__8[4]; + real r__1; + char ch__1[42], ch__2[1], ch__3[55], ch__4[54], ch__5[46]; + icilist ici__1; + + /* Builtin functions */ + integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle( + void), do_lio(integer *, integer *, char *, ftnlen), s_wsfe( + cilist *); + /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); + integer do_fio(integer *, char *, ftnlen), e_wsfe(void), s_cmp(char *, + char *, ftnlen, ftnlen), i_nint(real *); + double log(doublereal); + integer pow_ii(integer *, integer *), s_rsfe(cilist *), e_rsfe(void), + s_rsfi(icilist *), e_rsfi(void); + + /* Local variables */ + extern integer i1fnodur_(integer *, char *, ftnlen); + extern /* Subroutine */ int checkdyn_(char *, integer *, integer *, + ftnlen); + static integer idotform, ndxquote, i__, j; + extern /* Subroutine */ int readmeter_(char *, integer *, integer *, + integer *, ftnlen), getpmxmod_(logical *, char *, ftnlen); + static integer ic, igr, ipm; + static real dum; + static integer ngr, iiv, nbb4, num1, num2; + extern /* Character */ VOID chax_(char *, ftnlen, integer *); + static logical cdot; + static real fnum; + static char dumq[1], dotq[1], durq[1]; + static integer itup; + static real snum; + static integer ntup; + extern /* Subroutine */ int g1etx_(char *, integer *, logical *, logical * + , integer *, real *, real *, ftnlen), stop1_(void), read10_(char * + , logical *, ftnlen); + static real dimen; + static char charq[1]; + static integer indxb; + static char lineq[128]; + static integer icsav, ndoub, iorig, iinow, iposn, ninow; + extern /* Subroutine */ int getitransinfo_(logical *, integer *, char *, + integer *, integer *, integer *, integer *, integer *, ftnlen); + static integer icclhw; + static char charlq[1]; + extern /* Subroutine */ int setmac_(char *, integer *, integer *, integer + *, integer *, char *, char *, integer *, integer *, ftnlen, + ftnlen, ftnlen), chklit_(char *, integer *, integer *, ftnlen); + static logical fulbrp; + extern /* Subroutine */ int errmsg_(char *, integer *, integer *, char *, + ftnlen, ftnlen); + static integer literr, mtrdnp; + static real sysflb; + static integer numint, mtrnmp, numnum; + static logical ztrans; + static real fnsyst; + static integer lenbeat; + extern /* Subroutine */ int getchar_(char *, integer *, char *, ftnlen, + ftnlen), getmidi_(integer *, char *, integer *, integer *, + integer *, integer *, integer *, integer *, logical *, ftnlen), + readnum_(char *, integer *, char *, real *, ftnlen, ftnlen); + static integer mtrdenl, lenmult, numshft; + static logical plusmin; + static real tintstf; + extern /* Subroutine */ int g1etchar_(char *, integer *, char *, ftnlen, + ftnlen); + static integer lvoltxt; + + /* Fortran I/O blocks */ + static cilist io___558 = { 0, 6, 0, 0, 0 }; + static cilist io___559 = { 0, 6, 0, 0, 0 }; + static cilist io___560 = { 0, 6, 0, 0, 0 }; + static cilist io___561 = { 0, 6, 0, 0, 0 }; + static cilist io___562 = { 0, 15, 0, "(/a)", 0 }; + static cilist io___563 = { 0, 15, 0, "(a11,2x,i3)", 0 }; + static cilist io___564 = { 0, 15, 0, 0, 0 }; + static cilist io___565 = { 0, 6, 0, 0, 0 }; + static cilist io___573 = { 0, 6, 0, 0, 0 }; + static cilist io___574 = { 0, 6, 0, 0, 0 }; + static cilist io___575 = { 0, 6, 0, 0, 0 }; + static cilist io___580 = { 0, 6, 0, 0, 0 }; + static cilist io___581 = { 0, 6, 0, 0, 0 }; + static cilist io___582 = { 0, 6, 0, 0, 0 }; + static cilist io___595 = { 0, 6, 0, 0, 0 }; + static cilist io___598 = { 0, 6, 0, 0, 0 }; + static cilist io___599 = { 0, 6, 0, 0, 0 }; + static cilist io___600 = { 0, 6, 0, 0, 0 }; + static cilist io___603 = { 0, 6, 0, 0, 0 }; + static cilist io___609 = { 0, 6, 0, 0, 0 }; + static cilist io___610 = { 0, 6, 0, 0, 0 }; + static cilist io___611 = { 0, 15, 0, "(/,a)", 0 }; + static cilist io___612 = { 0, 6, 0, 0, 0 }; + static cilist io___613 = { 0, 6, 0, 0, 0 }; + static cilist io___614 = { 0, 15, 0, "(a)", 0 }; + static cilist io___615 = { 0, 15, 0, "(a)", 0 }; + static cilist io___623 = { 0, 6, 0, 0, 0 }; + static cilist io___624 = { 0, 6, 0, 0, 0 }; + static cilist io___625 = { 0, 6, 0, 0, 0 }; + static cilist io___626 = { 0, 6, 0, "(1x,a21,i3,a23)", 0 }; + static cilist io___630 = { 0, 6, 0, 0, 0 }; + static cilist io___631 = { 0, 6, 0, 0, 0 }; + static cilist io___632 = { 0, 5, 0, "(a)", 0 }; + static cilist io___636 = { 0, 6, 0, 0, 0 }; + static cilist io___637 = { 0, 6, 0, 0, 0 }; + + + cdot = FALSE_; +L1: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)charq != ' ') { + *(unsigned char *)charlq = *(unsigned char *)charq; + } + if (c1omget_1.lastchar) { + if (i_indx("/%", charlq, (ftnlen)2, (ftnlen)1) == 0) { + s_wsle(&io___558); + e_wsle(); + s_wsle(&io___559); + do_lio(&c__9, &c__1, "WARNING:", (ftnlen)8); + e_wsle(); + s_wsle(&io___560); + do_lio(&c__9, &c__1, "Last non-blank character is \"", (ftnlen)29) + ; + do_lio(&c__9, &c__1, charlq, (ftnlen)1); + do_lio(&c__9, &c__1, "\", not \"/,%\"", (ftnlen)12); + e_wsle(); + s_wsle(&io___561); + do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11); + i__1 = *(unsigned char *)charlq; + do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsle(); + s_wsfe(&io___562); +/* Writing concatenation */ + i__2[0] = 29, a__1[0] = "Last non-blank character is \""; + i__2[1] = 1, a__1[1] = charlq; + i__2[2] = 12, a__1[2] = "\", not \"/,%\""; + s_cat(ch__1, a__1, i__2, &c__3, (ftnlen)42); + do_fio(&c__1, ch__1, (ftnlen)42); + e_wsfe(); + s_wsfe(&io___563); + do_fio(&c__1, "ASCII code:", (ftnlen)11); + i__1 = *(unsigned char *)charlq; + do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsfe(); + +/* Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. */ + + --inbuff_1.ilbuf; + inbuff_1.lbuf[inbuff_1.ilbuf - 1] = (shortint) (inbuff_1.lbuf[ + inbuff_1.ilbuf - 1] + 2); +/* Writing concatenation */ + i__3[0] = inbuff_1.ipbuf, a__2[0] = inbuff_1.bufq; + i__3[1] = 2, a__2[1] = " /"; + s_cat(inbuff_1.bufq, a__2, i__3, &c__2, (ftnlen)65536); + s_wsle(&io___564); + do_lio(&c__9, &c__1, "appending /", (ftnlen)18); + e_wsle(); + s_wsle(&io___565); + do_lio(&c__9, &c__1, "appending /", (ftnlen)18); + e_wsle(); +/* Writing concatenation */ + i__3[0] = a1ll_2.iccount, a__2[0] = lineq; + i__3[1] = 2, a__2[1] = " /"; + s_cat(lineq, a__2, i__3, &c__2, (ftnlen)128); + c1omget_1.lastchar = FALSE_; + goto L1; + } + return 0; + } + if (*(unsigned char *)charq == ' ') { + goto L1; + } else if (*(unsigned char *)charq == '%' && a1ll_2.iccount == 1) { + a1ll_2.iccount = 128; + goto L1; + +/* Replacement 1/22/12 since gfortran 4.7 with -O was choking here! */ + +/* else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. */ + } else if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) > 0 || *( + unsigned char *)charq == 'r') { + +/* This is a note/rest. gotclef is only used for checking for clef before "/" */ + + if (cdot) { + goto L28; + } + if (c1omnotes_1.gotclef) { + c1omnotes_1.gotclef = FALSE_; + } + idotform = 0; + numnum = 0; + plusmin = FALSE_; +L28: + ++a1ll_2.nnl[c1ommvl_1.ivx - 1]; + if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 200) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, ">200 notes in line of mu" + "sic. Use smaller blocks!", (ftnlen)128, (ftnlen)48); + stop1_(); + } + *(unsigned char *)dotq = 'x'; + +/* Check if this is 'r ' and previous note was full-bar-pause */ + + i__1 = a1ll_2.iccount; +/* Computing MAX */ + i__4 = 1, i__5 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1; +/* Computing MAX */ + i__6 = 1, i__7 = a1ll_2.nnl[c1ommvl_1.ivx - 1] - 1; + fulbrp = *(unsigned char *)charq == 'r' && s_cmp(lineq + i__1, " ", + a1ll_2.iccount + 1 - i__1, (ftnlen)1) == 0 && a1ll_2.nnl[ + c1ommvl_1.ivx - 1] > 1 && a1ll_2.rest[c1ommvl_1.ivx + max( + i__4,i__5) * 24 - 25] && a1ll_2.nodur[c1ommvl_1.ivx + max( + i__6,i__7) * 24 - 25] == a1ll_2.lenbar; +L2: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + ic = *(unsigned char *)durq; + if (ic <= 57 && ic >= 48) { + +/* Digit */ + + if (numnum == 0) { + c1omnotes_1.nnodur = ic - 48; + numnum = 1; + goto L2; + } else if (numnum == 1) { + if (*(unsigned char *)charq == 'r') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only one digit a" + "llowed after rest symbol \"r\"!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + numnum = 2; + if (plusmin) { + s_wsle(&io___573); + e_wsle(); + s_wsle(&io___574); + do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen) + 25); + e_wsle(); + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1" + ".2, +/- was ignored if octave was!", (ftnlen)128, + (ftnlen)50); + s_wsle(&io___575); + do_lio(&c__9, &c__1, "explicitly specified. May need to" + " edit old editions", (ftnlen)52); + e_wsle(); + } + goto L2; + } else { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, ">2 digits in note sy" + "mbol!", (ftnlen)128, (ftnlen)25); + stop1_(); + } + } else if (*(unsigned char *)durq == 'd') { + *(unsigned char *)dotq = *(unsigned char *)durq; + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "d", a1ll_2.iccount + 1 - i__1, (ftnlen)1) + == 0) { + c1omnotes_1.iddot = 1; + ++a1ll_2.iccount; + +/* Since we flow out, double dots won't work with other dot options */ + + } + i__1 = a1ll_2.iccount; + if (i_indx("+-", lineq + i__1, (ftnlen)2, a1ll_2.iccount + 1 - + i__1) > 0) { + +/* move a dot, provided a number follows. */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) == 0) + { + +/* Backup, exit the loop normally */ + + a1ll_2.iccount += -2; + goto L2; + } + readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Vertical shift also */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("0123456789-.", durq, (ftnlen)12, (ftnlen)1) == + 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected num" + "ber after 2nd +/- (shift dot)!", (ftnlen)128, + (ftnlen)42); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, + (ftnlen)1); + } + --a1ll_2.iccount; + } + goto L2; + } else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Accidental shift */ + +/* if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then */ + i__1 = a1ll_2.iccount - 2; + if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 - + i__1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Expected \"f\", \"s\", \"n\" o" + "r \"A\" before \"<\" or \">\"!", (ftnlen)128, (ftnlen) + 48); +/* * 'Expected "f", "s", or "n" before "<" or ">"!') */ + stop1_(); + } + ipm = 1; + if (*(unsigned char *)durq == '<') { + ipm = -1; + } + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("123456789.0", durq, (ftnlen)11, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected number afte" + "r (accidental shift)!", (ftnlen)128, (ftnlen)45); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + fnum = ipm * fnum; + if (fnum < -5.35f || fnum > 1.f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Horizontal accidental shift mu" + "st be >-5.35 and <1.0!", (ftnlen)128, (ftnlen)52); + stop1_(); + } + --a1ll_2.iccount; + goto L2; + } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + if (*(unsigned char *)charq != 'r') { + i__1 = a1ll_2.iccount - 2; + if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - + 1 - i__1) > 0) { + ipm = 1; + if (*(unsigned char *)durq == '-') { + ipm = -1; + } + i__1 = a1ll_2.iccount; + if (i_indx("0123456789", lineq + i__1, (ftnlen)10, + a1ll_2.iccount + 1 - i__1) > 0) { + +/* This may be start of accidental shift, but may be octave jump; then duration */ + + icsav = a1ll_2.iccount; + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* This is an accid shift since there's a 2nd consecutive signed number. */ +/* Check size of 1st number. */ + + if (fnum > 30.5f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__1, &i__4, "Vertical accid" + "ental shift must be less than 31!", ( + ftnlen)128, (ftnlen)47); + stop1_(); + } + ipm = 1; + if (*(unsigned char *)durq == '-') { + ipm = -1; + } + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen) + 128, (ftnlen)1); + if (i_indx("1234567890.", durq, (ftnlen)11, ( + ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expe" + "cted 2nd number of accidental shift)!" + , (ftnlen)128, (ftnlen)41); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( + ftnlen)128, (ftnlen)1); + fnum = ipm * fnum; + if (fnum < -5.35f || fnum > 1.f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__1, &i__4, "Horiz. acciden" + "tal shift must be >-5.35 and <1.0!", ( + ftnlen)128, (ftnlen)48); + stop1_(); + } + --a1ll_2.iccount; + goto L2; + } else { + +/* Not accid shift, reset, then flow out */ + + a1ll_2.iccount = icsav; + } + } + } + plusmin = TRUE_; + if (numnum == 2) { + s_wsle(&io___580); + e_wsle(); + s_wsle(&io___581); + do_lio(&c__9, &c__1, "*********WARNING*********", (ftnlen) + 25); + e_wsle(); + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Before version 1" + ".2, +/- was ignored if octave was!", (ftnlen)128, + (ftnlen)50); + s_wsle(&io___582); + do_lio(&c__9, &c__1, "explicitly specified. May need to" + " edit old editions", (ftnlen)52); + e_wsle(); + } + goto L2; + +/* It's a rest containing +|- . Must refer to a vertical shift. Read past. */ + + } else { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + goto L2; + } +/* else if (index('ulare',durq) .gt. 0) then */ + } else if (i_indx("ularec", durq, (ftnlen)6, (ftnlen)1) > 0) { + goto L2; + } else if (*(unsigned char *)durq == 'S') { + +/* Stemlength change */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx(".0123456789:", durq, (ftnlen)12, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must be a numb" + "er or colon here!", (ftnlen)128, (ftnlen)37); + stop1_(); + } + if (*(unsigned char *)durq == ':') { + if (! comkeys_1.stickys) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned off stick" + "y stemshrinks without turning on!", (ftnlen)128, ( + ftnlen)49); + stop1_(); + } + comkeys_1.stickys = FALSE_; + goto L2; + } + readnum_(lineq, &a1ll_2.iccount, durq, &dum, (ftnlen)128, (ftnlen) + 1); + if (dum < .5f || dum > 4.f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Stemlength shortening must be " + "from .5 to 4!", (ftnlen)128, (ftnlen)43); + stop1_(); + } + if (*(unsigned char *)durq != ':') { + --a1ll_2.iccount; + } else { + if (comkeys_1.stickys) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on sticky" + " stemshrinks when already on!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + comkeys_1.stickys = TRUE_; + } + goto L2; + } else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) { + +/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */ +/* MUST come right after "f,s,n" */ + + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1) + == 0) { + ++a1ll_2.iccount; + } + goto L2; + } else if (*(unsigned char *)durq == 'p') { + fulbrp = *(unsigned char *)charq == 'r'; + if (! fulbrp) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "The option \"p\" onl" + "y works with \"r\" (rest)!", (ftnlen)128, (ftnlen)42); + stop1_(); + } + goto L2; + } else if (*(unsigned char *)durq == 'b') { + if (*(unsigned char *)charq != 'r') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"b\"; I" + " expected \"rb\"!", (ftnlen)128, (ftnlen)33); + stop1_(); + } else if (numnum == 2) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "You entered \"r\" &" + " \"b\" with two numbers!", (ftnlen)128, (ftnlen)39); + } + goto L2; + } else if (*(unsigned char *)durq == 'x') { + +/* Xtuplet. Count number of doubled notes (for unequal xtups) */ + + if (bit_test(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[ + c1ommvl_1.ivx - 1] * 24 - 25],18)) { + ndoub = 1; + } else { + ndoub = 0; + } + +/* Will set all durations to 0 except last one. */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "First char after \"" + "x\" in xtuplet must be \"1\"-\"9\"!", (ftnlen)128, ( + ftnlen)48); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (fnum > 99.f) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Xtuplet cannot have " + "more than 99 notes!", (ftnlen)128, (ftnlen)39); + stop1_(); + } else if (i_indx(" DFnd", durq, (ftnlen)5, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only legal character" + "s here are \" \",\"D\",\"F\",\"n\"!", (ftnlen)128, ( + ftnlen)47); + stop1_(); + } + +/* End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. */ + + if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Double xtup note to make an un= xtup. Here, number already set, but may also */ +/* have used this before number was set. */ + + c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],18); + ndoub = 1; + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + } else if (*(unsigned char *)durq == 'd') { + c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25],27); + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + } + if (*(unsigned char *)durq == 'n') { + +/* Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. */ + + numshft = 0; +L30: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)durq == 'f') { + goto L30; + } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + ++numshft; + if (numshft == 3) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only 2 shift" + "s are allowed after \"n\" in xtup!", (ftnlen) + 128, (ftnlen)44); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == + 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact" + "er should be a digit or \".\"!", (ftnlen)128, + (ftnlen)40); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, + (ftnlen)1); + --a1ll_2.iccount; + if (numshft == 1 && snum > 15.1f || numshft == 2 && snum + > 1.51f) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Shift number" + " after \"n\" in xtup is out of range!", ( + ftnlen)128, (ftnlen)47); + stop1_(); + } + goto L30; + } else if (*(unsigned char *)durq == 's') { + +/* Slope alteration for bracket */ + + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "For slope ad" + "justment, this character must be \"+\" or \"-" + "\"!", (ftnlen)128, (ftnlen)56); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) + { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "This charact" + "er should be a digit!", (ftnlen)128, (ftnlen) + 33); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, + (ftnlen)1); + --a1ll_2.iccount; + if (i_nint(&snum) > 15) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slope adjust" + "ment cannot exceed 15!", (ftnlen)128, (ftnlen) + 34); + stop1_(); + } + goto L30; + } else if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) > + 0) { + +/* Unsigned integer => alternate printed number */ + + readnum_(lineq, &a1ll_2.iccount, durq, &snum, (ftnlen)128, + (ftnlen)1); + if (snum > 15.1f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Alternate xtup number " + "after \"n\" must be <16!", (ftnlen)128, ( + ftnlen)44); + stop1_(); + } + --a1ll_2.iccount; + goto L30; + } else if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r after \"n\" in xtup!", (ftnlen)128, (ftnlen)36); + stop1_(); + } + } + ntup = i_nint(&fnum); + i__1 = ntup; + for (itup = 2; itup <= i__1; ++itup) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = 0; + ++a1ll_2.nnl[c1ommvl_1.ivx - 1]; +L110: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)durq == ' ') { + goto L110; + } else if (*(unsigned char *)durq == 'o') { + +/* Ornament in xtup. "o" symbol must come AFTER the affected note */ + + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("(stmx+Tup._)e:>^bc", dumq, (ftnlen)18, ( + ftnlen)1) == 0) { + if (i_indx("fg", dumq, (ftnlen)2, (ftnlen)1) > 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Fermata " + "or segno not allowed in xtuplet!", ( + ftnlen)128, (ftnlen)40); + } else { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal " + "ornament!", (ftnlen)128, (ftnlen)17); + } + stop1_(); + } + if (*(unsigned char *)dumq == 'T') { + +/* Trill. may be followed by 't' and/or number. read 'til blank */ + +L29: + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)dumq != ' ') { + goto L29; + } + } else if (*(unsigned char *)dumq == 'e') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal " + "character after \"e\" in edit. accid. sy" + "mbol!", (ftnlen)128, (ftnlen)51); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)dumq == '?') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen) + 128, (ftnlen)1); + } + } else if (*(unsigned char *)dumq == ':') { + i__4 = a1ll_2.iccount; + if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 - + i__4, (ftnlen)1) != 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu" + "st be followed by blank in \"o: \"!", ( + ftnlen)128, (ftnlen)39); + stop1_(); + } else if (! comkeys_1.ornrpt) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__4, &i__5, "Turned off repeate" + "d ornaments before they were on!", ( + ftnlen)128, (ftnlen)50); + stop1_(); + } + comkeys_1.ornrpt = FALSE_; + } else { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + } + if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" + "acter in ornament symbol!", (ftnlen)128, ( + ftnlen)37); + stop1_(); + } + if (*(unsigned char *)dumq == ':') { + i__4 = a1ll_2.iccount; + if (s_cmp(lineq + i__4, " ", a1ll_2.iccount + 1 - + i__4, (ftnlen)1) != 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "\":\" mu" + "st be followed by blank in \"o: \"!", ( + ftnlen)128, (ftnlen)39); + stop1_(); + } else if (comkeys_1.ornrpt) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Turned o" + "n repeated ornaments but already on!", ( + ftnlen)128, (ftnlen)44); + stop1_(); + } + comkeys_1.ornrpt = TRUE_; + } + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + i__4 = a1ll_2.iccount; + if (i_indx("0123456789", lineq + i__4, (ftnlen)10, + a1ll_2.iccount + 1 - i__4) == 0) { + i__4 = a1ll_2.iccount + 1; + i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__4, &i__5, "There should be an" + " integer here!", (ftnlen)128, (ftnlen)32); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + if (*(unsigned char *)durq == ':') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot s" + "hift AND repeat an ornament!", (ftnlen) + 128, (ftnlen)36); + stop1_(); + } + +/* 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. */ + + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + i__4 = a1ll_2.iccount; + if (i_indx(".0123456789", lineq + i__4, (ftnlen) + 11, a1ll_2.iccount + 1 - i__4) == 0) { + i__4 = a1ll_2.iccount + 1; + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__4, &i__5, "There should b" + "e a number here!", (ftnlen)128, ( + ftnlen)30); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( + ftnlen)128, (ftnlen)1); + } + } + goto L110; + } else if (i_indx("st(){}", durq, (ftnlen)6, (ftnlen)1) > 0) { + +/* Slur in xtup */ + + iposn = 0; + numint = 0; +L15: + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + ++iposn; + if (i_indx("udlbfnht", dumq, (ftnlen)8, (ftnlen)1) > 0) { + if (*(unsigned char *)dumq == 't' && *(unsigned char * + )durq == 't') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Cannot u" + "se \"t\" as an option on a tie!", (ftnlen) + 128, (ftnlen)37); + stop1_(); + } + goto L15; + } else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + ++numint; + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + if (numint == 1) { + if (i_nint(&fnum) > 30) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__4, &i__5, "Magnitude of s" + "lur height adjustment cannot exceed " + "30!", (ftnlen)128, (ftnlen)53); + stop1_(); + } + } else if (numint == 2) { + if (dabs(fnum) > 6.3f) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__4, &i__5, "Slur horiz shi" + "ft must be in the range (-6.3,6.3)!", + (ftnlen)128, (ftnlen)49); + stop1_(); + } + } else { + +/* Third signed integer, must be a midslur or curve spec. */ + + if (dabs(fnum) > 31.f) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__4, &i__5, "Slur midheight" + " must be in the range (-31,31)!", ( + ftnlen)128, (ftnlen)45); + stop1_(); + } + if (*(unsigned char *)durq == ':') { + +/* Expecting curve parameters. Get two numbers */ + + for (i__ = 1; i__ <= 2; ++i__) { + ++a1ll_2.iccount; + fnum = (real) (*(unsigned char *)&lineq[ + a1ll_2.iccount - 1] - 48); + if ((r__1 = fnum - 3.5f, dabs(r__1)) > + 3.6f) { + i__4 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, + "Slur curve parameter must " + "be in range (0,7)!", (ftnlen) + 128, (ftnlen)44); + stop1_(); + } +/* L40: */ + } + ++a1ll_2.iccount; + } + } + --a1ll_2.iccount; + goto L15; + } else if (*(unsigned char *)dumq == 's') { + +/* What follows should be one or two signed numbers for adjustment of line break */ +/* slur, end of 1st segment or start of second. */ + + if (comslur_1.fontslur) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "May not " + "use linebreak slur options with font-bas" + "ed slurs!", (ftnlen)128, (ftnlen)57); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "This cha" + "racter must be \"+\" or \"-\"!", (ftnlen) + 128, (ftnlen)34); + stop1_(); + } + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen) + 128, (ftnlen)1); + if (i_nint(&fnum) > 30) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__4, &i__5, "Magnitude of slur " + "height adjustment cannot exceed 30!", ( + ftnlen)128, (ftnlen)53); + stop1_(); + } + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, ( + ftnlen)128, (ftnlen)1); + if (dabs(fnum) > 6.3f) { + i__4 = a1ll_2.iccount - 1; + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__4, &i__5, "Slur horiz shi" + "ft must be in range (-6.3,6.3)!", ( + ftnlen)128, (ftnlen)45); + stop1_(); + } + } + --a1ll_2.iccount; + goto L15; + } else if (*(unsigned char *)dumq == 'H' && iposn > 1) { + i__4 = a1ll_2.iccount; + if (s_cmp(lineq + i__4, "H", a1ll_2.iccount + 1 - + i__4, (ftnlen)1) == 0) { + ++a1ll_2.iccount; + } + goto L15; + } else if (*(unsigned char *)dumq == 'p') { + +/* local change in postscript slur/tie adjustment default */ + + if (comslur_1.fontslur) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Must use" + " postscript slurs (\"Ap\") to use this o" + "ption!", (ftnlen)128, (ftnlen)52); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect" + "ed \"+\" or \"-\" here!", (ftnlen)128, ( + ftnlen)25); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expect" + "ed \"s\" or \"t\" here!", (ftnlen)128, ( + ftnlen)25); + stop1_(); + } + goto L15; + } else if (*(unsigned char *)dumq != ' ') { + ic = *(unsigned char *)dumq; + if (ic >= 48 && ic <= 57 || ic >= 65 && ic <= 90) { + if (iposn == 1) { + if (*(unsigned char *)durq == 't' && + comslur_1.fontslur) { + i__4 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, + "Slur ID not allowed on non-post" + "script tie!", (ftnlen)128, ( + ftnlen)42); + stop1_(); + } + goto L15; + } + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Slur ID " + "must be 2nd character in slur symbol!", ( + ftnlen)128, (ftnlen)45); + stop1_(); + } + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" + "acter in slur symbol!", (ftnlen)128, (ftnlen) + 33); + stop1_(); + } + goto L110; + } else if (i_indx("0123456789#-nx_", durq, (ftnlen)15, ( + ftnlen)1) > 0) { + +/* We have a figure. Only allow on 1st note of xtup */ + + if (itup != 2) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Figure in xt" + "up only allowed on 1st note!", (ftnlen)128, ( + ftnlen)40); + stop1_(); + } else if (*(unsigned char *)durq == 'x') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "No floating " + "figures in xtuplets!", (ftnlen)128, (ftnlen) + 32); + stop1_(); + } + if (compage_1.usefig && c1ommvl_1.ivx == 1) { + *ifig = 1; + } +L26: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("0123456789#-n_.:", durq, (ftnlen)16, (ftnlen) + 1) > 0) { + goto L26; + } else if (*(unsigned char *)durq == 's') { + comligfont_1.isligfont = TRUE_; + goto L26; + } else if (*(unsigned char *)durq == '+') { + +/* vertical offset, must be integer then blank */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) != + 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Integer " + "for vertical offset expected here!", ( + ftnlen)128, (ftnlen)42); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + if (*(unsigned char *)durq != ' ') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Vertical" + " offset must terminate figure!", (ftnlen) + 128, (ftnlen)38); + stop1_(); + } + --a1ll_2.iccount; + goto L26; + } else if (*(unsigned char *)durq != ' ') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal char" + "acter in figure in xtuplet!", (ftnlen)128, ( + ftnlen)39); + stop1_(); + } + goto L110; + } else if (*(unsigned char *)durq == 'G') { + ngr = 1; +L79: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) + { + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + ngr = i_nint(&fnum); + --a1ll_2.iccount; + goto L79; + } else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1) + > 0) { + goto L79; + } else if (*(unsigned char *)charq == 'm') { + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, + (ftnlen)1); + if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0) + { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "A digit " + "less than 5 must follow \"m\" in a grace" + " note!", (ftnlen)128, (ftnlen)52); + stop1_(); + } + goto L79; + } else if (*(unsigned char *)charq == 'X') { + +/* Space before main note */ + + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, + (ftnlen)1); + if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen) + 1) > 0) { + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, ( + ftnlen)128, (ftnlen)1); + --a1ll_2.iccount; + goto L79; + } else { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "A number" + " must follow \"X\" in a grace note!", ( + ftnlen)128, (ftnlen)41); + stop1_(); + } + } + +/* At this point, charq is first note name in rest (grace?) */ + + i__4 = ngr; + for (igr = 1; igr <= i__4; ++igr) { + numnum = 0; + if (igr > 1) { +L75: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen) + 128, (ftnlen)1); + if (*(unsigned char *)charq == ' ') { + goto L75; + } + } + if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == + 0) { + i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__5, "In grace" + ", expected \"a\"-\"g\"!", (ftnlen)128, ( + ftnlen)27); + stop1_(); + } +L78: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, + (ftnlen)1); + if (*(unsigned char *)charq != ' ') { + if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1) + > 0) { + if (numnum == 1) { + i__5 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__5, + "Only one of \"+-1234567\" allow" + "ed here in grace!", (ftnlen)128, ( + ftnlen)46); + stop1_(); + } + numnum = 1; + goto L78; + } else if (i_indx("+-nfs", charq, (ftnlen)5, ( + ftnlen)1) > 0) { + goto L78; + } + +/* Digits are possible octave numbers */ + + i__5 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__5, "Illegal " + "character after note name in grace!", ( + ftnlen)128, (ftnlen)43); + stop1_(); + } +/* L71: */ + } + goto L110; + } else /* if(complicated condition) */ { + chax_(ch__2, (ftnlen)1, &c__92); + if (*(unsigned char *)durq == *(unsigned char *)&ch__2[0]) + { + chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128); + if (literr > 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, literq + ( + literr - 1) * 51, (ftnlen)128, (ftnlen)51) + ; + stop1_(); + } + goto L110; + } else if (*(unsigned char *)durq == 'M') { + +/* Temporary trap until I get around putting this in pmxb */ + + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Macros not y" + "et allowed in xtuplets!", (ftnlen)128, ( + ftnlen)35); + stop1_(); + } else if (*(unsigned char *)durq == 'X') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + g1etx_(lineq, &a1ll_2.iccount, &c_false, & + comkeys_1.shifton, &i__4, &c1omnotes_1.udsp[ + c1omnotes_1.ibarcnt + a1ll_2.nbars], & + c1omnotes_1.wheadpt, (ftnlen)128); + goto L110; + } else if (*(unsigned char *)durq == 'z') { + +/* Chord note in xtup. Read past for now. */ + +L33: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)durq != ' ') { + goto L33; + } + goto L110; + } else if (*(unsigned char *)durq == 'D') { + +/* Dynamic mark */ + + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + checkdyn_(lineq, &a1ll_2.iccount, &i__4, (ftnlen)128); + goto L110; + } else if (*(unsigned char *)durq == '%') { + if (a1ll_2.iccount != 1) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Comment " + "must have \"%\" in column 1!", (ftnlen) + 128, (ftnlen)34); + stop1_(); + } + a1ll_2.iccount = 128; + goto L110; + } else if (*(unsigned char *)durq == '?') { + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)durq == ' ') { + --a1ll_2.iccount; + goto L110; + } + if (*(unsigned char *)durq != '-') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin" + "g \"-\"", (ftnlen)128, (ftnlen)13); + stop1_(); + } + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) + == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Expectin" + "g number", (ftnlen)128, (ftnlen)16); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen) + 128, (ftnlen)1); + --a1ll_2.iccount; + goto L110; +/* +++ */ + } else /* if(complicated condition) */ { + i__4 = a1ll_2.iccount; + i__5 = a1ll_2.iccount + 1; + if (*(unsigned char *)durq == ']' && s_cmp(lineq + + i__4, "[", a1ll_2.iccount + 1 - i__4, (ftnlen) + 1) == 0 && s_cmp(lineq + i__5, " ", + a1ll_2.iccount + 2 - i__5, (ftnlen)1) == 0) { + a1ll_2.iccount += 2; + goto L110; +/* +++ */ + } + } + } + +/* End of xtup options. At this point symbol can only be note or rest */ + + if (i_indx("abcdefgr", durq, (ftnlen)8, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "In xtup, this ch" + "aracter is not allowed!", (ftnlen)128, (ftnlen)39) + ; + stop1_(); + } else if (*(unsigned char *)durq == 'r' && itup == ntup) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Sorry, PMX canno" + "t end an xtuplet with a rest!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } +L7: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("2345678ulcb", durq, (ftnlen)11, (ftnlen)1) > 0) { + goto L7; + } else if (i_indx("sfn", durq, (ftnlen)3, (ftnlen)1) > 0) { + +/* Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. */ + + i__4 = a1ll_2.iccount; + if (s_cmp(lineq + i__4, "i", a1ll_2.iccount + 1 - i__4, ( + ftnlen)1) == 0) { + ++a1ll_2.iccount; + } + goto L7; + } else if (i_indx("+-<>", durq, (ftnlen)4, (ftnlen)1) > 0) { + +/* May have either octave jump or shifted accid. on main xtup note */ + + i__4 = a1ll_2.iccount; + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0 && + i_indx("01234567890", lineq + i__4, (ftnlen)11, + a1ll_2.iccount + 1 - i__4) == 0) { + goto L7; + } + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, + (ftnlen)1); + --a1ll_2.iccount; + goto L7; + } else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Double an xtup note to make an unequal xtup */ + + c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - + 1] * 24 - 25] = bit_set(c1ommvl_1.nacc[ + c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25],18); + ++ndoub; + goto L7; + } else if (*(unsigned char *)durq == 'd') { + c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - + 1] * 24 - 25] = bit_set(c1ommvl_1.nacc[ + c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25],27); + goto L7; + } else if (*(unsigned char *)durq != ' ') { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal option o" + "n xtuplet note!", (ftnlen)128, (ftnlen)31); + stop1_(); + } + if (itup == ntup - ndoub) { + goto L3; + } +/* L6: */ + } +L3: + +/* 6==End of loop for xtuplet input */ + + ; + } else if (*(unsigned char *)durq == 'm') { + +/* Multi-bar rest: next 1 or two digits are # of bars. */ + + if (a1ll_2.itsofar[a1ll_2.iv - 1] % a1ll_2.lenbar != 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Multibar rest must start at be" + "ginning of bar!", (ftnlen)128, (ftnlen)45); + stop1_(); + } else if (a1ll_2.iv == 1 && c1omnotes_1.ibarmbr > 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Multibar rest only OK at one t" + "ime per block!", (ftnlen)128, (ftnlen)44); + stop1_(); + } + +/* For some purposes, pretend its one bar only */ + + a1ll_2.nodur[a1ll_2.iv + a1ll_2.nnl[a1ll_2.iv - 1] * 24 - 25] = + a1ll_2.lenbar; + c1omnotes_1.ibarmbr = a1ll_2.nbars + 1; + c1omnotes_1.mbrest = 0; +/* 20 call g1etchar(lineq,iccount,durq) */ + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected an integer " + "after \"rm\"!", (ftnlen)128, (ftnlen)31); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + c1omnotes_1.mbrest = i_nint(&fnum); + --a1ll_2.iccount; +/* if (ichar(durq).ge.48.and.ichar(durq).le.57) then */ +/* mbrest = 10*mbrest+ichar(durq)-48 */ +/* go to 20 */ +/* end if */ + if (a1ll_2.nv > 1) { + if (a1ll_2.iv == 1) { + comkeys_1.mbrestsav = c1omnotes_1.mbrest; + } else { + if (c1omnotes_1.mbrest != comkeys_1.mbrestsav) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must enter s" + "ame multi-bar rest in every voice!", (ftnlen) + 128, (ftnlen)46); + stop1_(); + } + } + +/* Zero out mbrestsav so can check at end of input block whether */ +/* all voices have one */ + + if (a1ll_2.iv == a1ll_2.nv) { + comkeys_1.mbrestsav = 0; + } + } + if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" + "ter \"rm\"!", (ftnlen)128, (ftnlen)29); + stop1_(); + } + } else if (*(unsigned char *)durq == '.') { + +/* Dotted pattern. Close out note. Mult time by 3/4. */ +/* Set time for next note to 1/4. Start the note. */ + + idotform = 1; + } else if (*(unsigned char *)durq == ',') { + idotform = 3; + +/* Now flow to duration setting, as if durq=' ' */ + + } else if (i_indx("oL", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Suppress full bar rest, or look left for height */ + + if (*(unsigned char *)charq != 'r') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",\"L\" options " + "only legal for rest, not note!", (ftnlen)128, (ftnlen) + 46); + stop1_(); + } + goto L2; + } else if (i_indx("DF", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Double note for xtup. Must check here in case "D" or "F" came before "x" or on */ +/* last note of xtup. Need to flag it in pmxa since affects horiz. spacing. */ + + c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 + - 25] = bit_set(c1ommvl_1.nacc[c1ommvl_1.ivx + a1ll_2.nnl[ + c1ommvl_1.ivx - 1] * 24 - 25],18); + goto L2; + } else if (*(unsigned char *)durq == 'A') { + +/* Main note accidental option */ + + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("o+-<>", durq, (ftnlen)5, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\",+\",\"-\",\"" + "<\",\">\" are the only legal options here!", (ftnlen) + 128, (ftnlen)51); + stop1_(); + } + +/* Need more stuff here */ + + if (*(unsigned char *)durq != 'o') { + +/* Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will */ +/* proceed to number input checking */ + + --a1ll_2.iccount; + } + goto L2; + } else if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character!", ( + ftnlen)128, (ftnlen)18); + s_wsle(&io___595); + do_lio(&c__9, &c__1, "ASCII code:", (ftnlen)11); + i__1 = *(unsigned char *)durq; + do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer)); + e_wsle(); + stop1_(); + } + +/* End of block for note options. */ + +/* Set the duration */ + + if (idotform > 0) { + if (idotform == 1) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, ( + ftnlen)1) * 3 / 2; + } else if (idotform == 2) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[ + c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 3; + } else if (idotform == 3) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, ( + ftnlen)1); + } else if (idotform == 4) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[ + c1ommvl_1.ivx - 1] - 1) * 24 - 25] / 2; + } + } else if (c1omnotes_1.ibarmbr != a1ll_2.nbars + 1 && ! fulbrp) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - + 25] = i1fnodur_(&c1omnotes_1.nnodur, dotq, (ftnlen)1); + +/* Check for double dot */ + + if (c1omnotes_1.iddot == 1) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] = a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[ + c1ommvl_1.ivx - 1] * 24 - 25] * 7 / 6; + c1omnotes_1.iddot = 0; + } + } else if (fulbrp) { + a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - + 25] = a1ll_2.lenbar; + +/* Use a one-line function to set nnodur. It gives inverse of ifnodur. */ + + i__1 = (integer) (log(a1ll_2.lenbar + .1f) / .69315f) + 48; + chax_(ch__2, (ftnlen)1, &i__1); + c1omnotes_1.nnodur = i_indx("62514x0x37", ch__2, (ftnlen)10, ( + ftnlen)1) - 1; + fulbrp = FALSE_; + } + a1ll_2.rest[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25] = + *(unsigned char *)charq == 'r'; + +/* If inside forced beam, check if note is beamable */ + + if (c1omget_1.fbon) { + if (a1ll_2.nodur[c1ommvl_1.ivx + a1ll_2.nnl[c1ommvl_1.ivx - 1] * + 24 - 25] < 16) { + goto L120; + } + if (a1ll_2.nnl[c1ommvl_1.ivx - 1] > 1) { + if (a1ll_2.nodur[c1ommvl_1.ivx + (a1ll_2.nnl[c1ommvl_1.ivx - + 1] - 1) * 24 - 25] == 0) { + goto L120; + } + } + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Unbeamable thing in forc" + "ed beam!", (ftnlen)128, (ftnlen)32); + stop1_(); + } +L120: + +/* Get number of prior bars for later check on whether note spans bar line */ + + nbb4 = a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar; + a1ll_2.itsofar[c1ommvl_1.ivx - 1] += a1ll_2.nodur[c1ommvl_1.ivx + + a1ll_2.nnl[c1ommvl_1.ivx - 1] * 24 - 25]; + if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] % a1ll_2.lenbar == 0) { + ++a1ll_2.nbars; + if (comkeys_1.shifton) { + comkeys_1.barend = TRUE_; + } + +/* Will check barend when 1st note of next bar is entered. */ + + if (a1ll_2.nbars > 15) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot have more tha" + "n 15 bars in an input block!", (ftnlen)128, (ftnlen) + 48); + stop1_(); + } + a1ll_2.nib[c1ommvl_1.ivx + a1ll_2.nbars * 24 - 25] = a1ll_2.nnl[ + c1ommvl_1.ivx - 1]; + if (a1ll_2.firstline && a1ll_2.lenbar != a1ll_2.lenbr1) { + +/* Just finished the pickup bar for this voice. */ + + if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] != a1ll_2.lenbr0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Pickup bar lengt" + "h disagrees with mtrnum0!", (ftnlen)128, (ftnlen) + 41); + stop1_(); + } + a1ll_2.lenbar = a1ll_2.lenbr1; + a1ll_2.itsofar[c1ommvl_1.ivx - 1] = 0; + } + } else if (comkeys_1.barend) { + if (comkeys_1.shifton) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Bar ended with user-" + "defined shift still on!", (ftnlen)128, (ftnlen)43); + stop1_(); + } + comkeys_1.barend = FALSE_; + } else if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] / a1ll_2.lenbar > nbb4) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &i__1, &i__4, "This note spans a bar line!", ( + ftnlen)128, (ftnlen)27); + stop1_(); + } + if (idotform == 1 || idotform == 3) { + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("abcedfgr", charq, (ftnlen)8, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected note name o" + "r \"r\" here!", (ftnlen)128, (ftnlen)31); + stop1_(); + } + ++idotform; + numnum = 1; + goto L28; + } + +/* End of sub block for note-rest */ + + } else if (*(unsigned char *)charq == 'z') { + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected chord note name" + " here!", (ftnlen)128, (ftnlen)30); + stop1_(); + } +L25: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); +/* if (index('dre12345678',durq) .gt. 0) then */ + if (i_indx("dre12345678c", durq, (ftnlen)12, (ftnlen)1) > 0) { + goto L25; + } else if (i_indx("fsn", durq, (ftnlen)3, (ftnlen)1) > 0) { + +/* Check for midi-only accid. CANNOT coesist with accidental position tweaks, so */ +/* MUST come right after "f,s,n" */ + + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "i", a1ll_2.iccount + 1 - i__1, (ftnlen)1) + == 0) { + ++a1ll_2.iccount; + } + goto L25; + } else if (*(unsigned char *)durq == 'A') { + i__1 = a1ll_2.iccount - 2; + if (i_indx("fsn", lineq + i__1, (ftnlen)3, a1ll_2.iccount - 1 - + i__1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n\" before \"" + "A\" in chord note!", (ftnlen)128, (ftnlen)43); + stop1_(); + } + goto L25; + } else if (i_indx("<>", durq, (ftnlen)2, (ftnlen)1) > 0) { + i__1 = a1ll_2.iccount - 2; + if (i_indx("fsnA", lineq + i__1, (ftnlen)4, a1ll_2.iccount - 1 - + i__1) == 0) { +/* if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems */ + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Must have \"f,s,n,A\" before" + " \"<\" or \">\"!", (ftnlen)128, (ftnlen)38); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("1234567890.", durq, (ftnlen)11, (ftnlen)1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Expected a number to start her" + "e for accidental shift!", (ftnlen)128, (ftnlen)53); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + goto L25; + } else if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + i__1 = a1ll_2.iccount; + if (i_indx("1234567890.", lineq + i__1, (ftnlen)11, + a1ll_2.iccount + 1 - i__1) == 0) { + goto L25; + } + +/* Number or '.' (durq) follows +/- . Get it. */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + i__1 = a1ll_2.iccount; + if (*(unsigned char *)durq == '.' && i_indx("1234567890", lineq + + i__1, (ftnlen)10, a1ll_2.iccount + 1 - i__1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "\".\" here must be followed by" + " a digit!", (ftnlen)128, (ftnlen)37); + stop1_(); + } else /* if(complicated condition) */ { + i__1 = a1ll_2.iccount - 3; + if (i_indx("sfndA", lineq + i__1, (ftnlen)5, a1ll_2.iccount - + 2 - i__1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Number after +/- must foll" + "ow \"d,s,f,n,A\"!", (ftnlen)128, (ftnlen)41); + stop1_(); + } + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) == 0) { + --a1ll_2.iccount; + goto L25; + } + +/* 2nd +/- */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)durq == '.') { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + } + if (i_indx("1234567890", durq, (ftnlen)10, (ftnlen)1) == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Expected a number here!", ( + ftnlen)128, (ftnlen)23); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + goto L25; + } else if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in cho" + "rd note!", (ftnlen)128, (ftnlen)32); + stop1_(); + } + } else if (*(unsigned char *)charq == 'G') { + ngr = 1; +L9: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) > 0) { + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + ngr = i_nint(&fnum); + --a1ll_2.iccount; + goto L9; + } else if (i_indx("AWulxs", charq, (ftnlen)6, (ftnlen)1) > 0) { + goto L9; + } else if (*(unsigned char *)charq == 'm') { + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("01234", charq, (ftnlen)5, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "A digit less than 5 " + "must follow \"m\" in a grace note!", (ftnlen)128, ( + ftnlen)52); + stop1_(); + } + goto L9; + } else if (*(unsigned char *)charq == 'X') { + +/* Space before main note */ + + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("0123456789.", charq, (ftnlen)11, (ftnlen)1) > 0) { + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + goto L9; + } else { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "A number must foll" + "ow \"X\" in a grace note!", (ftnlen)128, (ftnlen)41); + stop1_(); + } + } + +/* At this point, charq is first note name in rest (grace?) */ + + i__1 = ngr; + for (igr = 1; igr <= i__1; ++igr) { + numnum = 0; + if (igr > 1) { +L55: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)charq == ' ') { + goto L55; + } + } + if (i_indx("abcdefg", charq, (ftnlen)7, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "In grace, expected" + " \"a\"-\"g\"!", (ftnlen)128, (ftnlen)27); + stop1_(); + } +L18: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)charq != ' ') { + if (i_indx("1234567", charq, (ftnlen)7, (ftnlen)1) > 0) { + if (numnum == 1) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Only one of" + " \"+-1234567\" allowed here in grace!", ( + ftnlen)128, (ftnlen)46); + stop1_(); + } + numnum = 1; + goto L18; +/* else if (index('nfs',charq) .gt. 0) then */ + } else if (i_indx("+-nfs", charq, (ftnlen)5, (ftnlen)1) > 0) { + goto L18; + } + +/* Digits are possible octave numbers */ + + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "Illegal character af" + "ter note name in grace!", (ftnlen)128, (ftnlen)43); + stop1_(); + } +/* L19: */ + } + } else /* if(complicated condition) */ { + chax_(ch__2, (ftnlen)1, &c__92); + if (*(unsigned char *)charq == *(unsigned char *)&ch__2[0]) { + chklit_(lineq, &a1ll_2.iccount, &literr, (ftnlen)128); + if (literr > 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, literq + (literr - 1) * + 51, (ftnlen)128, (ftnlen)51); + stop1_(); + } + } else if (*(unsigned char *)charq == 'o') { + +/* Ornament on non-xtup note. "o" symbol must come AFTER the affected note */ + + if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"o\" must be in sam" + "e input block, after affected note!", (ftnlen)128, ( + ftnlen)53); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1); + if (i_indx("(stmgx+Tupf._)e:>^bc", dumq, (ftnlen)20, (ftnlen)1) == + 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal ornament!", ( + ftnlen)128, (ftnlen)17); + stop1_(); + } + if (*(unsigned char *)dumq == ':') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)dumq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected blank a" + "fter \"o:\"!", (ftnlen)128, (ftnlen)26); + stop1_(); + } else if (! comkeys_1.ornrpt) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Turned off repeated orname" + "nts before they were on!", (ftnlen)128, (ftnlen) + 50); + stop1_(); + } + comkeys_1.ornrpt = FALSE_; + } else if (*(unsigned char *)dumq == 'g') { + if (c1omget_1.issegno) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Sorry, only one" + " \"segno\" per input block!", (ftnlen)128, ( + ftnlen)40); + stop1_(); + } else if (c1ommvl_1.ivx != 1) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "segno can only b" + "e in voice 1!", (ftnlen)128, (ftnlen)29); + stop1_(); + } + c1omget_1.issegno = TRUE_; +L12: + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)dumq == '-' || *(unsigned char *)dumq >= + 48 && *(unsigned char *)dumq <= 58) { + goto L12; + } + if (*(unsigned char *)dumq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r in segno ornament symbol!", (ftnlen)128, ( + ftnlen)43); + stop1_(); + } + } else if (*(unsigned char *)dumq == 'T') { + +/* Trill. may be followed by 't' and/or number. read 'til blank */ + +L22: + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)dumq == ':') { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) != 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected bla" + "nk after \":\"!", (ftnlen)128, (ftnlen)25); + stop1_(); + } + goto L32; + } else if (*(unsigned char *)dumq != ' ') { + goto L22; + } + } else if (*(unsigned char *)dumq == 'f') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (i_indx(" d+-:", dumq, (ftnlen)5, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r after \"f\" in fermata ornament symbol!", ( + ftnlen)128, (ftnlen)55); + stop1_(); + } + if (*(unsigned char *)dumq == 'd') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + } + if (*(unsigned char *)dumq == ':') { + goto L32; + } + } else if (*(unsigned char *)dumq == 'e') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("sfn?", dumq, (ftnlen)4, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r after \"e\" in edit. accid. symbol!", (ftnlen) + 128, (ftnlen)51); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)dumq == '?') { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, ( + ftnlen)1); + } + } else { + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + } + if (i_indx("+- :", dumq, (ftnlen)4, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in" + " ornament symbol!", (ftnlen)128, (ftnlen)37); + stop1_(); + } + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + i__1 = a1ll_2.iccount; + if (i_indx("0123456789", lineq + i__1, (ftnlen)10, + a1ll_2.iccount + 1 - i__1) == 0) { + i__1 = a1ll_2.iccount + 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "There should be an integer" + " here!", (ftnlen)128, (ftnlen)32); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)durq == ':') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot shift AND" + " repeat an ornament!", (ftnlen)128, (ftnlen)36); + stop1_(); + } + +/* 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. */ + + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + i__1 = a1ll_2.iccount; + if (i_indx(".0123456789", lineq + i__1, (ftnlen)11, + a1ll_2.iccount + 1 - i__1) == 0) { + i__1 = a1ll_2.iccount + 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "There should be a numb" + "er here!", (ftnlen)128, (ftnlen)30); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, + (ftnlen)1); + } + } +L32: + if (*(unsigned char *)dumq == ':') { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) != 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\":\" must be fo" + "llowed by blank in \"o: \"!", (ftnlen)128, ( + ftnlen)39); + stop1_(); + } else if (comkeys_1.ornrpt) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Turned on repeat" + "ed ornaments but already on!", (ftnlen)128, ( + ftnlen)44); + stop1_(); + } + comkeys_1.ornrpt = TRUE_; + } + } else if (i_indx("st(){}", charq, (ftnlen)6, (ftnlen)1) > 0) { + numint = 0; + iposn = 0; +L8: + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen)1); + ++iposn; + if (*(unsigned char *)charq == 't' && *(unsigned char *)dumq == + 't') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot use \"t\" as " + "an option on a tie!", (ftnlen)128, (ftnlen)37); + stop1_(); + } + if (i_indx("udltb+-fnhHps ", dumq, (ftnlen)14, (ftnlen)1) == 0) { + +/* Check for explicit ID code. */ + + ic = *(unsigned char *)dumq; + if (ic < 48 || ic > 57 && ic < 65 || ic > 90) { + +/* Not 0-9 or A-Z, so exit */ + + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r in slur symbol!", (ftnlen)128, (ftnlen)33); + stop1_(); + } else { + +/* It is a possible ID code. Right place? */ + + if (iposn != 1) { + +/* Slur ID is not 2nd! */ + + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID must" + " be second character in slur symbol!", ( + ftnlen)128, (ftnlen)48); + stop1_(); + } else if (*(unsigned char *)charq == 't' && + comslur_1.fontslur) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur ID not " + "allowed on non-postscript tie!", (ftnlen)128, + (ftnlen)42); + stop1_(); + } + } + +/* Slur ID is OK. Note it cannot be "H" at this point.. */ + + goto L8; + } else if (*(unsigned char *)dumq == 'H') { + if (iposn == 1) { + goto L8; + } + +/* "H" is NOT an ID code. */ + + if (! comslur_1.fontslur && *(unsigned char *)charq == 't') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape p" + "ostscript ties this way!", (ftnlen)128, (ftnlen) + 40); + stop1_(); + } + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) == 0) { + ++a1ll_2.iccount; + ++iposn; + } + goto L8; + } else if (i_indx("fh", dumq, (ftnlen)2, (ftnlen)1) > 0 && ! + comslur_1.fontslur && *(unsigned char *)charq == 't') { + +/* 3/9/03 Can't reshape postscript tie. */ + + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot reshape posts" + "cript ties this way!", (ftnlen)128, (ftnlen)40); + stop1_(); + } else if (*(unsigned char *)dumq == 'p') { + +/* local change in postscript slur/tie adjustment default */ + + if (comslur_1.fontslur) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must use postscr" + "ipt slurs (\"Ap\") to use this option!", (ftnlen) + 128, (ftnlen)52); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"+\" o" + "r \"-\" here!", (ftnlen)128, (ftnlen)25); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("st", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected \"s\" o" + "r \"t\" here!", (ftnlen)128, (ftnlen)25); + stop1_(); + } + iposn += 2; + goto L8; + } + if (i_indx("udltbfnh", dumq, (ftnlen)8, (ftnlen)1) > 0) { + goto L8; + } else if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + ++numint; + if (comslur_1.fontslur && *(unsigned char *)charq == 't') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+|-\" for slur" + " height only allowed in \"s\"-slurs!", (ftnlen) + 128, (ftnlen)48); + stop1_(); + } + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (numint == 1) { + if (i_nint(&fnum) > 30) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Magnitude of slur heig" + "ht adjustment cannot exceed 30!", (ftnlen)128, + (ftnlen)53); + stop1_(); + } + } else if (numint == 2) { + if (dabs(fnum) > 6.3f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must " + "be in range (-6.3,6.3)!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + } else { + +/* Third signed integer, must be a midslur or curve spec. */ + + if (dabs(fnum) > 31.f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Slur midheight must be" + " in the range (-31,31)!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + if (*(unsigned char *)durq == ':') { + +/* Expecting curve parameters. Get two numbers */ + + for (i__ = 1; i__ <= 2; ++i__) { + ++a1ll_2.iccount; + fnum = (real) (*(unsigned char *)&lineq[ + a1ll_2.iccount - 1] - 48); + if ((r__1 = fnum - 3.5f, dabs(r__1)) > 3.6f) { + i__1 = c1omnotes_1.ibarcnt - + c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Slur" + " curve parameter must be in range (0" + ",7)!", (ftnlen)128, (ftnlen)44); + stop1_(); + } +/* L41: */ + } + ++a1ll_2.iccount; + } + } + --a1ll_2.iccount; + goto L8; + } else if (*(unsigned char *)dumq == 's') { + +/* What follows should be one or two signed numbers for adjustment of line break */ +/* slur, end of 1st segment or start of second. */ + + if (comslur_1.fontslur) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "May not use line" + "break slur options with font-based slurs!", ( + ftnlen)128, (ftnlen)57); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, dumq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "This character m" + "ust be \"+\" or \"-\"!", (ftnlen)128, (ftnlen)34); + stop1_(); + } + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (i_nint(&fnum) > 30) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Magnitude of slur height a" + "djustment cannot exceed 30!", (ftnlen)128, ( + ftnlen)53); + stop1_(); + } + if (i_indx("+-", dumq, (ftnlen)2, (ftnlen)1) > 0) { + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, dumq, &fnum, (ftnlen)128, + (ftnlen)1); + if (dabs(fnum) > 6.3f) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Slur horiz shift must " + "be in range (-6.3,6.3)!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + } + --a1ll_2.iccount; + goto L8; + } else if (*(unsigned char *)dumq == 'H' && iposn > 1) { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "H", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) == 0) { + ++a1ll_2.iccount; + } + goto L8; + } + } else if (*(unsigned char *)charq == '?') { + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)durq == ' ') { + --a1ll_2.iccount; + } else { + if (*(unsigned char *)durq != '-') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting \"-\"!", + (ftnlen)128, (ftnlen)14); + stop1_(); + } + getchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1) + ; + if (i_indx("0123456789.", durq, (ftnlen)11, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expecting number!" + , (ftnlen)128, (ftnlen)17); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + } + } else if (*(unsigned char *)charq >= 48 && *(unsigned char *)charq <= + 57 || i_indx("#-nx_", charq, (ftnlen)5, (ftnlen)1) > 0) { + +/* We have a figure. Must come AFTER the note it goes under */ + + if (a1ll_2.itsofar[c1ommvl_1.ivx - 1] == 0 && (! a1ll_2.firstline + || a1ll_2.lenbr0 == 0 || a1ll_2.lenbar == a1ll_2.lenbr0)) + { + +/* Figure before first note in block */ + + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Cannot put figure be" + "fore first note in block!", (ftnlen)128, (ftnlen)45); + stop1_(); + } + if (*(unsigned char *)charq == 'x') { + indxb = i_indx(lineq + (a1ll_2.iccount - 1), " ", 128 - ( + a1ll_2.iccount - 1), (ftnlen)1); + if (indxb < 5) { + i__1 = a1ll_2.iccount + indxb - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Cannot have a blank here i" + "n floating figure!", (ftnlen)128, (ftnlen)44); + stop1_(); + } + } + if (compage_1.usefig) { + *ifig = 1; + } +L5: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx(" 0123456789#-nx_.:+s", charq, (ftnlen)20, (ftnlen)1) + == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character in" + " figure!", (ftnlen)128, (ftnlen)28); + stop1_(); + } else if (*(unsigned char *)charq == '+') { + +/* vertical offset, must be integer, then blank */ + + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("123456789", charq, (ftnlen)9, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Integer for vert" + "ical offset expected here!", (ftnlen)128, (ftnlen) + 42); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, charq, &fnum, (ftnlen)128, ( + ftnlen)1); + if (*(unsigned char *)charq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Vertical offset " + "must terminate figure!", (ftnlen)128, (ftnlen)38); + stop1_(); + } + --a1ll_2.iccount; + goto L5; + } else if (*(unsigned char *)charq == 's') { + comligfont_1.isligfont = TRUE_; + } + if (*(unsigned char *)charq != ' ') { + goto L5; + } + } else if (*(unsigned char *)charq == '[') { + if (c1omget_1.fbon) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Started forced beam " + "while another was open!", (ftnlen)128, (ftnlen)43); + stop1_(); + } + c1omget_1.fbon = TRUE_; +L17: + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (i_indx("uljhf:", charq, (ftnlen)6, (ftnlen)1) > 0) { + goto L17; + } else if (i_indx("+-", charq, (ftnlen)2, (ftnlen)1) > 0) { + ++a1ll_2.iccount; + readnum_(lineq, &a1ll_2.iccount, durq, &fnum, (ftnlen)128, ( + ftnlen)1); + --a1ll_2.iccount; + goto L17; + } else if (*(unsigned char *)charq == 'm') { + +/* Forced multiplicity, next char should be 1-4 */ + + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("1234", charq, (ftnlen)4, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced multiplic" + "ity for a beam must be 1, 2, 3, or 4!", (ftnlen) + 128, (ftnlen)53); + stop1_(); + } + goto L17; + } else if (*(unsigned char *)charq != ' ') { + if (i_indx("0123456789", charq, (ftnlen)10, (ftnlen)1) > 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "After \"[\", dig" + "its must now be preceeded by \"+\" or \"-\"!", ( + ftnlen)128, (ftnlen)54); + s_wsle(&io___598); + do_lio(&c__9, &c__1, "You will have to edit older source" + "s to meet this rqmt,", (ftnlen)54); + e_wsle(); + s_wsle(&io___599); + do_lio(&c__9, &c__1, "but it was needed to allow 2-digit" + " height adjustments.", (ftnlen)54); + e_wsle(); + s_wsle(&io___600); + do_lio(&c__9, &c__1, "Sorry for the inconvenience. --Th" + "e Management", (ftnlen)46); + e_wsle(); + } else { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal characte" + "r after [!", (ftnlen)128, (ftnlen)26); + } + stop1_(); + } + } else if (*(unsigned char *)charq == ']') { + if (! c1omget_1.fbon) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Forced beam stop wit" + "h no corresponding start!", (ftnlen)128, (ftnlen)45); + stop1_(); + } + g1etchar_(lineq, &a1ll_2.iccount, charq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)charq == '-') { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, "[ ", a1ll_2.iccount + 2 - i__1, ( + ftnlen)2) != 0) { + i__1 = a1ll_2.iccount + 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Only sequence allowed here" + " is \"[ \"!", (ftnlen)128, (ftnlen)35); + stop1_(); + } else { + a1ll_2.iccount += 2; + } + } else if (*(unsigned char *)charq == '[') { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) != 0) { + i__1 = a1ll_2.iccount + 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "This character must be a b" + "lank!", (ftnlen)128, (ftnlen)31); + stop1_(); + } + } else { + +/* Forced beam is really ending */ + + c1omget_1.fbon = FALSE_; + if (*(unsigned char *)charq == 'j') { + i__1 = a1ll_2.iccount; + if (s_cmp(lineq + i__1, " ", a1ll_2.iccount + 1 - i__1, ( + ftnlen)1) != 0) { + i__1 = a1ll_2.iccount + 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "This character must be" + " a blank!", (ftnlen)128, (ftnlen)31); + stop1_(); + } + } else if (*(unsigned char *)charq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"]\" must be fo" + "llowed by blank, \"j\", \"-\", or \"[\"!", ( + ftnlen)128, (ftnlen)48); + stop1_(); + } + } + } else if (*(unsigned char *)charq == 'D') { + +/* Dynamic mark */ + + if (a1ll_2.nnl[c1ommvl_1.ivx - 1] == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"D\" must not come " + "before any notes have been entered!", (ftnlen)128, ( + ftnlen)53); + stop1_(); + } + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + a1ll_2.nbars + + 1; + checkdyn_(lineq, &a1ll_2.iccount, &i__1, (ftnlen)128); + } else if (i_indx("lhw", charq, (ftnlen)3, (ftnlen)1) > 0) { + +/* Save position for later check */ + + icclhw = a1ll_2.iccount; + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("0123456789.+- ", durq, (ftnlen)14, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" + "ter \"l\", \"w\", or \"h\"!", (ftnlen)128, (ftnlen)41) + ; + stop1_(); + } + c1omget_1.isheadr = c1omget_1.isheadr || *(unsigned char *)charq + == 'h'; + if (i_indx(" +-", durq, (ftnlen)3, (ftnlen)1) > 0) { + +/* There is a header (or lower string?) */ + + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* User-defined vert offset (\internote). */ + + if (*(unsigned char *)charq != 'h') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"+\" or \"" + "-\" not permitted here!", (ftnlen)128, ( + ftnlen)30); + stop1_(); + } + +/* Have "h" followed by +/- . Check for digit. */ +/* Can blow durq since not using fnum for now, but... */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("123456789", durq, (ftnlen)9, (ftnlen)1) == 0) + { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "There must b" + "e a digit here!", (ftnlen)128, (ftnlen)27); + stop1_(); + } + +/* Have "h" followed by +/- followed by a digit. No need to get the number. */ + +/* call readnum(lineq,iccount,durq,fnum) */ + } + if (*(unsigned char *)charq != 'w') { + +/* Header or lower string. */ + + if (icclhw != 1) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "\"h\" or \"l\" must be" + " first character in line!", (ftnlen)128, ( + ftnlen)43); + stop1_(); + } + +/* Read past the next line, which has the string. */ + + read10_(charq, &c1omget_1.lastchar, (ftnlen)1); + ++c1omget_1.nline; + a1ll_2.iccount = 128; + } else { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol \"w\" (wi" + "dth) must be followed by a digit!", (ftnlen)128, ( + ftnlen)47); + stop1_(); + } + } else { + +/* Height or width change spec. Check if at start of piece. */ + + if (c1omnotes_1.ibarcnt > 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Symbol must go a" + "t top of first input block!", (ftnlen)128, ( + ftnlen)43); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &dimen, (ftnlen)128, ( + ftnlen)1); + +/* Check units. Convert to points */ + + if (*(unsigned char *)durq == ' ' || *(unsigned char *)durq == + 'p') { + dimen += .5f; + } else if (*(unsigned char *)durq == 'i') { + dimen = dimen * 72 + .5f; + } else if (*(unsigned char *)durq == 'm') { + dimen = dimen / 25.4f * 72 + .5f; + } else { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal unit; mu" + "st be \"p\",\"i\",or\"m\"!", (ftnlen)128, (ftnlen) + 36); + stop1_(); + } + if (*(unsigned char *)charq == 'h') { + compage_1.ptheight = (real) ((integer) dimen); + } else { + compage_1.widthpt = (real) ((integer) dimen); + } + } + } else if (*(unsigned char *)charq == 'm') { + +/* Time signature change. Only allow at beginning of block. */ +/* mtrnuml, mtrdenl (logical) and p (printable) will be input. */ +/* mtrnuml=0 initially. (In common) */ + +/* Check whether at beginning of a block */ + + if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Meter change only OK" + " in voice 1, at start of block!", (ftnlen)128, ( + ftnlen)51); + s_wsle(&io___603); + do_lio(&c__9, &c__1, "voice number is", (ftnlen)15); + do_lio(&c__3, &c__1, (char *)&c1ommvl_1.ivx, (ftnlen)sizeof( + integer)); + e_wsle(); + stop1_(); + } + a1ll_2.newmeter = TRUE_; + readmeter_(lineq, &a1ll_2.iccount, &a1ll_2.mtrnuml, &mtrdenl, ( + ftnlen)128); + if (a1ll_2.mtrnuml == 0) { + i__1 = a1ll_2.iccount - 1; + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &i__1, &i__4, "Digit 0 not allowed here!", ( + ftnlen)128, (ftnlen)25); + stop1_(); +/* else if (mtrdenl .eq. 1) then */ +/* c */ +/* c Kluge!!! */ +/* c */ +/* mtrdenl = 2 */ +/* mtrnuml = 2*mtrnuml */ + } + readmeter_(lineq, &a1ll_2.iccount, &mtrnmp, &mtrdnp, (ftnlen)128); + +/* Read past printed time signature; not used in pmxa. */ + + lenbeat = i1fnodur_(&mtrdenl, "x", (ftnlen)1); + lenmult = 1; + if (mtrdenl == 2) { + lenbeat = 16; + lenmult = 2; + } + a1ll_2.lenbar = lenmult * a1ll_2.mtrnuml * lenbeat; + a1ll_2.mtrnuml = 0; + } else if (*(unsigned char *)charq == 'C') { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (! (i_indx("tsmanrbf", durq, (ftnlen)8, (ftnlen)1) > 0 || *( + unsigned char *)durq >= 48 && *(unsigned char *)durq <= + 55)) { +/* * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then */ + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must have t,s,m,a,n," + "r,b,f or 1-7 after C!", (ftnlen)128, (ftnlen)41); +/* * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') */ + stop1_(); + } + c1omnotes_1.gotclef = TRUE_; + } else if (*(unsigned char *)charq == 'R') { + if (c1ommvl_1.ivx != 1) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Repeats can only go " + "in voice 1!", (ftnlen)128, (ftnlen)31); + stop1_(); + } +L10: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("lrdDbz", durq, (ftnlen)6, (ftnlen)1) > 0) { + goto L10; + } + if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Illegal character af" + "ter \"R\" (repeat/double bar)!", (ftnlen)128, (ftnlen) + 48); + stop1_(); + } + } else if (*(unsigned char *)charq == 'V') { + +/* Ending */ + + if (a1ll_2.iv != 1) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Voltas are only allo" + "wed in voice #1!", (ftnlen)128, (ftnlen)36); + stop1_(); + } else if (c1omget_1.isvolt) { + s_wsle(&io___609); + e_wsle(); + s_wsle(&io___610); + do_lio(&c__9, &c__1, "*******WARNING********", (ftnlen)22); + e_wsle(); + s_wsfe(&io___611); + do_fio(&c__1, "*******WARNING********", (ftnlen)22); + e_wsfe(); + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "There is more than o" + "ne volta in this input block.!", (ftnlen)128, (ftnlen) + 50); + s_wsle(&io___612); + do_lio(&c__9, &c__1, "This may work in a score, but WILL NOT" + " work in parts.", (ftnlen)53); + e_wsle(); + s_wsle(&io___613); + do_lio(&c__9, &c__1, "Safest to have only 1 volta per block," + " at the start of the block", (ftnlen)64); + e_wsle(); + s_wsfe(&io___614); + do_fio(&c__1, "This may work in a score, but WILL NOT work i" + "n parts.", (ftnlen)53); + e_wsfe(); + s_wsfe(&io___615); + do_fio(&c__1, "Safest to have only 1 volta per block, at the" + " start of the block", (ftnlen)64); + e_wsfe(); + } + c1omget_1.isvolt = TRUE_; + lvoltxt = 0; +L11: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)durq != ' ') { + goto L11; + } + } else if (*(unsigned char *)charq == 'B') { + } else if (*(unsigned char *)charq == 'P') { + if (c1ommvl_1.ivx != 1 || a1ll_2.nnl[0] != 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only allowed at begi" + "nning of block!", (ftnlen)128, (ftnlen)35); + stop1_(); + } +L16: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (*(unsigned char *)durq == 'l' || *(unsigned char *)durq == + 'r' || *(unsigned char *)durq >= 48 && *(unsigned char *) + durq <= 57) { + goto L16; + } + if (*(unsigned char *)durq == 'c') { + +/* Expect a centered name, and it has to be last option */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (*(unsigned char *)durq == '"') { + +/* Quoted name, go to next quote mark */ + + for (++a1ll_2.iccount; a1ll_2.iccount <= 127; + ++a1ll_2.iccount) { + if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] == + '"') { + goto L36; + } +/* L35: */ + } + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Missing close qu" + "ote after page number command (P)!", (ftnlen)128, + (ftnlen)50); + stop1_(); +L36: + ; + } else if (*(unsigned char *)durq != ' ') { + +/* Space-delimited name, look for next blank */ + + for (++a1ll_2.iccount; a1ll_2.iccount <= 127; + ++a1ll_2.iccount) { + if (*(unsigned char *)&lineq[a1ll_2.iccount - 1] == + ' ') { + goto L38; + } +/* L37: */ + } +L38: + ; + } + } else if (*(unsigned char *)durq != ' ') { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only \"l\",\"r\",\"" + "c\" or digit allowed after \"P\"!", (ftnlen)128, ( + ftnlen)44); + stop1_(); + } + } else if (*(unsigned char *)charq == 'W') { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx(".0123456789", durq, (ftnlen)11, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Expected a number to" + " start here!", (ftnlen)128, (ftnlen)32); + stop1_(); + } + readnum_(lineq, &a1ll_2.iccount, durq, &c1omnotes_1.wminnh[ + c1omnotes_1.ibarcnt + a1ll_2.nbars], (ftnlen)128, (ftnlen) + 1); + } else if (*(unsigned char *)charq == 'T') { + +/* Titles */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("itc", durq, (ftnlen)3, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Must put \"i\", \"" + "t\", or \"c\" after \"T\"!", (ftnlen)128, (ftnlen)36); + stop1_(); + } + i__1 = i_indx("itc", durq, (ftnlen)3, (ftnlen)1) - 1; + c1omget_1.ihead += pow_ii(&c__2, &i__1); + +/* Maybe a number after 'Tt', but ignore here. Read past string on next line. */ + + read10_(charq, &c1omget_1.lastchar, (ftnlen)1); + ++c1omget_1.nline; + a1ll_2.iccount = 128; + } else if (*(unsigned char *)charq == 'A') { +L27: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen)1); + if (i_indx("rbsdeK", durq, (ftnlen)6, (ftnlen)1) > 0) { + goto L27; + } else if (*(unsigned char *)durq == 'v') { + if (c1omnotes_1.ibarcnt == 0) { + comnvst_1.novshrinktop = TRUE_; + } + goto L27; + } else if (*(unsigned char *)durq == 'a') { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + readnum_(lineq, &a1ll_2.iccount, durq, &c1ommvl_1.fbar, ( + ftnlen)128, (ftnlen)1); + --a1ll_2.iccount; + goto L27; + } else if (*(unsigned char *)durq == 'i') { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + +/* Local interstaff correction. Set to -1. if not specifiec, or after use, */ +/* or anytime except at top, since pmxb handles all times except at top. */ + + readnum_(lineq, &a1ll_2.iccount, durq, &tintstf, (ftnlen)128, + (ftnlen)1); + if (c1omnotes_1.ibarcnt == 0) { + compage_1.fintstf = tintstf; + } + --a1ll_2.iccount; + goto L27; + } else if (*(unsigned char *)durq == 'I') { + +/* Global interstaff correction. Use in place of fintstf if fintstf<0 */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + readnum_(lineq, &a1ll_2.iccount, durq, &compage_1.gintstf, ( + ftnlen)128, (ftnlen)1); + --a1ll_2.iccount; + goto L27; + } else if (*(unsigned char *)durq == 'o') { + *optimize = TRUE_; + goto L27; + } else if (*(unsigned char *)durq == 'S') { + i__1 = a1ll_2.nv; + for (iiv = 1; iiv <= i__1; ++iiv) { + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("-0st", durq, (ftnlen)4, (ftnlen)1) == 0) { + i__4 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__4, "After \"AS\"" + ", need nv instances of \"s,t,-,0\"!", (ftnlen) + 128, (ftnlen)43); + stop1_(); + } + if (*(unsigned char *)durq == '-' || *(unsigned char *) + durq == 's') { + comsize_1.isize[iiv - 1] = 1; + } else if (*(unsigned char *)durq == 't') { + comsize_1.isize[iiv - 1] = 2; + } +/* L50: */ + } + goto L27; + } else if (*(unsigned char *)durq == 'p') { + comslur_1.fontslur = FALSE_; +L42: + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, (ftnlen) + 1); + if (i_indx("+-", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Characters to change defaults for ps slurs */ + + g1etchar_(lineq, &a1ll_2.iccount, durq, (ftnlen)128, ( + ftnlen)1); + if (i_indx("shtc", durq, (ftnlen)4, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "Only letters" + " allowed here are \"s\",\"h\",\"t\",\"c\"!", ( + ftnlen)128, (ftnlen)46); + stop1_(); + } + +/* Now check for another default modifier */ + + goto L42; + } else if (i_indx("lh", durq, (ftnlen)2, (ftnlen)1) > 0) { + +/* Flags for optional linebreak ties or header specials */ + + goto L42; + } else { + --a1ll_2.iccount; + } + goto L27; + } else if (*(unsigned char *)durq == 'N') { + +/* Override default name for a part file. Must have part number, then */ +/* partname in quotes. Must be on line by itself, and start in column 1. */ +/* Will only be passed thru to scor2prt. */ + + if (a1ll_2.iccount != 2) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must star" + "t in column 1!", (ftnlen)128, (ftnlen)28); + stop1_(); + } + ndxquote = i_indx(lineq, "\"", (ftnlen)128, (ftnlen)1); + if (ndxquote < 4 || ndxquote > 5 || i_indx("123456789", lineq + + 2, (ftnlen)9, (ftnlen)1) == 0 || ndxquote == 5 && + i_indx("012", lineq + 3, (ftnlen)3, (ftnlen)1) == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "\"AN\" must be f" + "ollowed by inst. #, then quote!", (ftnlen)128, ( + ftnlen)45); + stop1_(); + } + i__1 = ndxquote; + ndxquote = i_indx(lineq + i__1, "\"", 128 - i__1, (ftnlen)1); + if (ndxquote == 0) { + i__1 = c1omnotes_1.ibarcnt - c1omnotes_1.ibaroff + + a1ll_2.nbars + 1; + errmsg_(lineq, &a1ll_2.iccount, &i__1, "In \"AN\", file " + "name must be in quotes!", (ftnlen)128, (ftnlen)37) + ; + stop1_(); + } + a1ll_2.iccount = 128; + } else if (*(unsigned char *)durq == 'T') { + comnvst_1.cstuplet = TRUE_; + } else if (*(unsigned char *)durq == 'R') { + +/* Get full name of normal include file; must occupy remainder of line */ + + i__1 = a1ll_2.iccount; + getpmxmod_(&c_false, lineq + i__1, 128 - i__1); + a1ll_2.iccount = 128; + } else if (*(unsigned char *)durq != ' ') { + 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. */ +/* <>???? */ + +/* 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 */ + + 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 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; } -- cgit v1.2.3